Commit 73d643c0 authored by MrMan's avatar MrMan

Use DataKinds for type-level task completion tracking

parent 01e3551c
...@@ -6,11 +6,16 @@ ...@@ -6,11 +6,16 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module Components.TaskStore.SQLite module Components.TaskStore.SQLite
(SQLiteTaskStore) (SQLiteTaskStore)
where where
import Control.Applicative((<|>))
import Components.TaskStore.Migrations.SQLite (migrations) import Components.TaskStore.Migrations.SQLite (migrations)
import Config (CompleteTaskStoreConfig, TaskStoreConfig(..)) import Config (CompleteTaskStoreConfig, TaskStoreConfig(..))
import Control.Exception (SomeException(..), throw, catch, try) import Control.Exception (SomeException(..), throw, catch, try)
...@@ -62,6 +67,9 @@ instance FromField TaskName where ...@@ -62,6 +67,9 @@ instance FromField TaskName where
instance FromField TaskDesc where instance FromField TaskDesc where
fromField = (TaskDesc <$>) . (fromField :: FieldParser DT.Text) fromField = (TaskDesc <$>) . (fromField :: FieldParser DT.Text)
instance FromField TaskStateValue where
fromField = (TaskStateValue <$>) . (fromField :: FieldParser DT.Text)
instance ToField TaskDesc where instance ToField TaskDesc where
toField = SQLText . getTDesc toField = SQLText . getTDesc
...@@ -74,8 +82,10 @@ instance ToRow a => ToRow (WithID a) where ...@@ -74,8 +82,10 @@ instance ToRow a => ToRow (WithID a) where
toRow (UUIDID id_ obj) = [toField id_] <> toRow obj toRow (UUIDID id_ obj) = [toField id_] <> toRow obj
toRow (Int64ID id_ obj) = [toField id_] <> toRow obj toRow (Int64ID id_ obj) = [toField id_] <> toRow obj
instance ToField state => ToRow (FullySpecifiedTask state) where instance forall (state :: TaskState). ToRow (FullySpecifiedTask state) where
toRow t = toRow (tName t, tDescription t, tState t) toRow t@(FinishedT name desc) = toRow (name, desc, showState t)
toRow t@(InProgressT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
toRow t@(NotStartedT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
instance FromRow a => FromRow (WithID a) where instance FromRow a => FromRow (WithID a) where
-- While normally FromRow instances are written like: `ValueConstructor <$> field <*> field ...` -- While normally FromRow instances are written like: `ValueConstructor <$> field <*> field ...`
...@@ -103,11 +113,32 @@ instance FromField TaskState where ...@@ -103,11 +113,32 @@ instance FromField TaskState where
SQLText txt -> pure $ read $ DT.unpack txt SQLText txt -> pure $ read $ DT.unpack txt
fd -> returnError ConversionFailed f "Unexpected TaskState field type" fd -> returnError ConversionFailed f "Unexpected TaskState field type"
instance (FromField state) => FromRow (FullySpecifiedTask state) where instance forall (state :: TaskState). FromRow (FullySpecifiedTask state) where
fromRow = Task <$> field <*> field <*> field fromRow = UnknownStateT <$> field <*> field <*> field
instance (FromField state) => FromRow (PartialTask state) where instance FromRow (FullySpecifiedTask 'Finished) where
fromRow = Task <$> field <*> field <*> field fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "Finished") -> pure (FinishedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
instance FromRow (FullySpecifiedTask 'InProgress) where
fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "InProgress") -> pure (InProgressT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
instance FromRow (FullySpecifiedTask 'NotStarted) where
fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "NotStarted") -> pure (NotStartedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
disconnectionError :: IO (Either TaskStoreError a) disconnectionError :: IO (Either TaskStoreError a)
disconnectionError = pure $ Left $ Disconnected "Store is disconnected" disconnectionError = pure $ Left $ Disconnected "Store is disconnected"
...@@ -115,7 +146,7 @@ disconnectionError = pure $ Left $ Disconnected "Store is disconnected" ...@@ -115,7 +146,7 @@ disconnectionError = pure $ Left $ Disconnected "Store is disconnected"
makeGenericInsertError :: SomeException -> IO (Either TaskStoreError a) makeGenericInsertError :: SomeException -> IO (Either TaskStoreError a)
makeGenericInsertError = pure . Left . UnexpectedError . ("INSERT command failed: " <>) . DT.pack . show makeGenericInsertError = pure . Left . UnexpectedError . ("INSERT command failed: " <>) . DT.pack . show
saveAndReturnTask :: ToField state => Connection -> WithID (FullySpecifiedTask state) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state))) saveAndReturnTask :: forall (state :: TaskState). Connection -> WithID (FullySpecifiedTask state) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
saveAndReturnTask c t = catch doInsert makeGenericInsertError saveAndReturnTask c t = catch doInsert makeGenericInsertError
where where
doInsert = execute c "INSERT INTO tasks (uuid, name, description, state) VALUES (?,?,?,?)" t doInsert = execute c "INSERT INTO tasks (uuid, name, description, state) VALUES (?,?,?,?)" t
...@@ -123,7 +154,7 @@ saveAndReturnTask c t = catch doInsert makeGenericInsertError ...@@ -123,7 +154,7 @@ saveAndReturnTask c t = catch doInsert makeGenericInsertError
instance TaskStore SQLiteTaskStore where instance TaskStore SQLiteTaskStore where
persistTask :: SQLiteTaskStore -> Validated (FullySpecifiedTask TaskState) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask TaskState))) persistTask :: forall (state :: TaskState). SQLiteTaskStore -> Validated (FullySpecifiedTask state) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
persistTask store (Validated newTask) = maybe disconnectionError _handler $ stsConn store persistTask store (Validated newTask) = maybe disconnectionError _handler $ stsConn store
where where
-- | _handler does all the real work of persisting a task -- | _handler does all the real work of persisting a task
...@@ -134,13 +165,13 @@ instance TaskStore SQLiteTaskStore where ...@@ -134,13 +165,13 @@ instance TaskStore SQLiteTaskStore where
completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask)) completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask))
completeTask = undefined completeTask = undefined
getTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state))) getTask :: forall (state :: TaskState). SQLiteTaskStore -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
getTask = undefined getTask = undefined
updateTask :: c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state))) updateTask :: forall (state :: TaskState). SQLiteTaskStore -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
updateTask = undefined updateTask = undefined
deleteTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state))) deleteTask :: forall (state :: TaskState). SQLiteTaskStore -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask = undefined deleteTask = undefined
instance FromRow SQLMigrationVersion where instance FromRow SQLMigrationVersion where
......
...@@ -7,9 +7,14 @@ ...@@ -7,9 +7,14 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ExplicitForAll #-}
module Types where module Types where
import Data.Kind(Type)
import Config (CompleteTaskStoreConfig) import Config (CompleteTaskStoreConfig)
import Control.Exception (throw, Exception) import Control.Exception (throw, Exception)
import Data.Either (isRight) import Data.Either (isRight)
...@@ -21,11 +26,6 @@ import Data.Monoid ((<>)) ...@@ -21,11 +26,6 @@ import Data.Monoid ((<>))
import Data.UUID (UUID, toText, fromText) import Data.UUID (UUID, toText, fromText)
import qualified Data.Text as DT import qualified Data.Text as DT
-- Individual separate types for tasks to enable specifying them as part of (Task f state)
data Finished = FinishedState deriving (Eq, Read, Show)
data InProgress = InProgressState deriving (Eq, Read, Show)
data NotStarted = NotStartedState deriving (Eq, Read, Show)
-- Task state for abstracting over TaskState -- Task state for abstracting over TaskState
data TaskState = Finished data TaskState = Finished
| InProgress | InProgress
...@@ -35,36 +35,41 @@ data TaskState = Finished ...@@ -35,36 +35,41 @@ data TaskState = Finished
newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show) newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show)
newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show) newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show)
newtype TaskStateValue = TaskStateValue { getTStateLiteral :: DT.Text } deriving (Eq, Show)
-- The beefy task class -- The beefy task class
data Task f state = Task { tName :: f TaskName data Task f (state :: TaskState) where
, tDescription :: f TaskDesc FinishedT :: f TaskName -> f TaskDesc -> Task f 'Finished
, tState :: f state InProgressT :: f TaskName -> f TaskDesc -> Task f 'InProgress
} NotStartedT :: f TaskName -> f TaskDesc -> Task f 'NotStarted
-- | The case where we don't know what the state actually is
-- Ex. when we pull a value from the DB, we can't be polymorphic over state with the other constructors
-- but the database *has* to know what was stored forthe state.
-- Once we have an UnknownStateT we can write functions that try to translate to what we expect/require and fail otherwise.
UnknownStateT :: f TaskName -> f TaskDesc -> TaskStateValue -> Task f state
resolveFinishedT :: forall (state :: TaskState) (f :: Type -> Type). Task f state -> Either ValidationError (Task f 'Finished)
resolveFinishedT (t@FinishedT{}) = Right t
resolveFinishedT (UnknownStateT name desc stateValue) = case stateValue of
(TaskStateValue "Finished") -> Right (FinishedT name desc)
_ -> Left $ WrongState "Task state is incompatible (not in finished state)"
resolveFinishedT _ = Left $ WrongState "Task state is incompatible (not in finished state)"
-- Completed tasks -- Completed tasks
type CompletedTask = Task Identity Finished type CompletedTask = Task Identity 'Finished
deriving instance Eq CompletedTask
deriving instance Show CompletedTask
-- InProgress, partially specified tasks -- InProgress, partially specified tasks
type InProgressPartialTask = Task Maybe InProgress type InProgressPartialTask = Task Maybe 'InProgress
deriving instance Eq InProgressPartialTask
deriving instance Show InProgressPartialTask
-- InProgress, fully specified tasks -- InProgress, fully specified tasks
type InProgressTask = Task Identity InProgress type InProgressTask = Task Identity 'InProgress
deriving instance Eq InProgressTask
deriving instance Show InProgressTask
-- Not started, partially specified tasks -- Not started, partially specified tasks
type NotStartedPartialTask = Task Maybe NotStarted type NotStartedPartialTask = Task Maybe 'NotStarted
deriving instance Eq NotStartedPartialTask
deriving instance Show NotStartedPartialTask
-- Not started, completely specified tasks -- Not started, completely specified tasks
type NotStartedTask = Task Identity NotStarted type NotStartedTask = Task Identity 'NotStarted
deriving instance Eq NotStartedTask
deriving instance Show NotStartedTask
---------------- ----------------
-- Validation -- -- Validation --
...@@ -73,7 +78,8 @@ deriving instance Show NotStartedTask ...@@ -73,7 +78,8 @@ deriving instance Show NotStartedTask
newtype FieldName = FieldName { getFieldName :: DT.Text } deriving (Eq, Show, Read) newtype FieldName = FieldName { getFieldName :: DT.Text } deriving (Eq, Show, Read)
data ValidationError = InvalidField FieldName data ValidationError = InvalidField FieldName
| MissingField FieldName deriving (Eq, Show, Read) | MissingField FieldName
| WrongState DT.Text deriving (Eq, Show, Read)
instance Exception ValidationError instance Exception ValidationError
instance Exception [ValidationError] instance Exception [ValidationError]
...@@ -98,12 +104,7 @@ class Validatable t where ...@@ -98,12 +104,7 @@ class Validatable t where
validationChecks :: [ValidationCheck t] validationChecks :: [ValidationCheck t]
type FullySpecifiedTask = Task Identity type FullySpecifiedTask = Task Identity
deriving instance Eq (FullySpecifiedTask TaskState)
deriving instance Show (FullySpecifiedTask TaskState)
type PartialTask = Task Maybe type PartialTask = Task Maybe
deriving instance Eq (PartialTask TaskState)
deriving instance Show (PartialTask TaskState)
taskNameField :: FieldName taskNameField :: FieldName
taskNameField = FieldName "name" taskNameField = FieldName "name"
...@@ -111,16 +112,21 @@ taskNameField = FieldName "name" ...@@ -111,16 +112,21 @@ taskNameField = FieldName "name"
taskDescField :: FieldName taskDescField :: FieldName
taskDescField = FieldName "description" taskDescField = FieldName "description"
showState :: forall (state :: TaskState) (f :: Type -> Type). Task f state -> String
showState (FinishedT _ _) = "Finished"
showState (InProgressT _ _) = "InProgress"
showState (NotStartedT _ _) = "NotStarted"
-- | Helper function to access task name for fully specified task -- | Helper function to access task name for fully specified task
-- this works for both `FullySpecifiedTask state` (where state can vary, e.g. s`CompletedTask`(~`Task Identity Finished`) or `IncompleteTask`s (~`Task Identity InProgress`)
fsTaskName :: FullySpecifiedTask state -> DT.Text fsTaskName :: FullySpecifiedTask state -> DT.Text
fsTaskName = DT.strip . getTName . runIdentity . tName fsTaskName (FinishedT (Identity name) _) = DT.strip $ getTName name
fsTaskName (InProgressT (Identity name) _) = DT.strip $ getTName name
fsTaskName (NotStartedT (Identity name) _) = DT.strip $ getTName name
fsTaskDesc :: FullySpecifiedTask state -> DT.Text fsTaskDesc :: FullySpecifiedTask state -> DT.Text
fsTaskDesc = DT.strip . getTDesc . runIdentity . tDescription fsTaskDesc (FinishedT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskDesc (InProgressT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskState :: FullySpecifiedTask TaskState -> TaskState fsTaskDesc (NotStartedT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskState = runIdentity . tState
instance Validatable (FullySpecifiedTask state) where instance Validatable (FullySpecifiedTask state) where
validationChecks = [checkName, checkDescription] validationChecks = [checkName, checkDescription]
...@@ -132,10 +138,15 @@ instance Validatable (FullySpecifiedTask state) where ...@@ -132,10 +138,15 @@ instance Validatable (FullySpecifiedTask state) where
checkDescription t = if DT.null (fsTaskDesc t) then Just (InvalidField taskDescField) else Nothing checkDescription t = if DT.null (fsTaskDesc t) then Just (InvalidField taskDescField) else Nothing
pTaskName :: PartialTask state -> Maybe DT.Text pTaskName :: PartialTask state -> Maybe DT.Text
pTaskName = (DT.strip . getTName <$>) . tName -- pTaskName = (DT.strip . getTName <$>) . tName
pTaskName (FinishedT name _) = DT.strip . getTName <$> name
pTaskName (InProgressT name _) = DT.strip . getTName <$> name
pTaskName (NotStartedT name _) = DT.strip . getTName <$> name
pTaskDesc :: PartialTask state -> Maybe DT.Text pTaskDesc :: PartialTask state -> Maybe DT.Text
pTaskDesc = (DT.strip . getTDesc <$>) . tDescription pTaskDesc (FinishedT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (InProgressT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (NotStartedT _ desc) = DT.strip . getTDesc <$> desc
instance Validatable (PartialTask state) where instance Validatable (PartialTask state) where
validationChecks = [checkName, checkDescription] validationChecks = [checkName, checkDescription]
...@@ -174,11 +185,11 @@ instance Exception TaskStoreError ...@@ -174,11 +185,11 @@ instance Exception TaskStoreError
newtype TaskID = TaskID { getTaskID :: Int } deriving (Eq, Show, Read) newtype TaskID = TaskID { getTaskID :: Int } deriving (Eq, Show, Read)
class Component c => TaskStore c where class Component c => TaskStore c where
persistTask :: c -> Validated (FullySpecifiedTask TaskState) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask TaskState))) persistTask :: forall (state :: TaskState). c -> Validated (FullySpecifiedTask state) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask)) completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask))
getTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state))) getTask :: forall (state :: TaskState). c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
updateTask :: c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state))) updateTask :: forall (state :: TaskState). c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state))) deleteTask :: forall (state :: TaskState). c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
data WithID a where data WithID a where
UUIDID :: UUID -> a -> WithID a UUIDID :: UUID -> a -> WithID a
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment