Commit 73d643c0 authored by MrMan's avatar MrMan

Use DataKinds for type-level task completion tracking

parent 01e3551c
......@@ -6,11 +6,16 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module Components.TaskStore.SQLite
(SQLiteTaskStore)
where
import Control.Applicative((<|>))
import Components.TaskStore.Migrations.SQLite (migrations)
import Config (CompleteTaskStoreConfig, TaskStoreConfig(..))
import Control.Exception (SomeException(..), throw, catch, try)
......@@ -62,6 +67,9 @@ instance FromField TaskName where
instance FromField TaskDesc where
fromField = (TaskDesc <$>) . (fromField :: FieldParser DT.Text)
instance FromField TaskStateValue where
fromField = (TaskStateValue <$>) . (fromField :: FieldParser DT.Text)
instance ToField TaskDesc where
toField = SQLText . getTDesc
......@@ -74,8 +82,10 @@ instance ToRow a => ToRow (WithID a) where
toRow (UUIDID id_ obj) = [toField id_] <> toRow obj
toRow (Int64ID id_ obj) = [toField id_] <> toRow obj
instance ToField state => ToRow (FullySpecifiedTask state) where
toRow t = toRow (tName t, tDescription t, tState t)
instance forall (state :: TaskState). ToRow (FullySpecifiedTask state) where
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
-- While normally FromRow instances are written like: `ValueConstructor <$> field <*> field ...`
......@@ -103,11 +113,32 @@ instance FromField TaskState where
SQLText txt -> pure $ read $ DT.unpack txt
fd -> returnError ConversionFailed f "Unexpected TaskState field type"
instance (FromField state) => FromRow (FullySpecifiedTask state) where
fromRow = Task <$> field <*> field <*> field
instance forall (state :: TaskState). FromRow (FullySpecifiedTask state) where
fromRow = UnknownStateT <$> field <*> field <*> field
instance FromRow (FullySpecifiedTask 'Finished) where
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 (FromField state) => FromRow (PartialTask state) where
fromRow = Task <$> field <*> field <*> field
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 = pure $ Left $ Disconnected "Store is disconnected"
......@@ -115,7 +146,7 @@ disconnectionError = pure $ Left $ Disconnected "Store is disconnected"
makeGenericInsertError :: SomeException -> IO (Either TaskStoreError a)
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
where
doInsert = execute c "INSERT INTO tasks (uuid, name, description, state) VALUES (?,?,?,?)" t
......@@ -123,7 +154,7 @@ saveAndReturnTask c t = catch doInsert makeGenericInsertError
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
where
-- | _handler does all the real work of persisting a task
......@@ -134,13 +165,13 @@ instance TaskStore SQLiteTaskStore where
completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask))
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
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
deleteTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask :: forall (state :: TaskState). SQLiteTaskStore -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask = undefined
instance FromRow SQLMigrationVersion where
......
......@@ -7,9 +7,14 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ExplicitForAll #-}
module Types where
import Data.Kind(Type)
import Config (CompleteTaskStoreConfig)
import Control.Exception (throw, Exception)
import Data.Either (isRight)
......@@ -21,11 +26,6 @@ import Data.Monoid ((<>))
import Data.UUID (UUID, toText, fromText)
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
data TaskState = Finished
| InProgress
......@@ -35,36 +35,41 @@ data TaskState = Finished
newtype TaskName = TaskName { getTName :: 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
data Task f state = Task { tName :: f TaskName
, tDescription :: f TaskDesc
, tState :: f state
}
data Task f (state :: TaskState) where
FinishedT :: f TaskName -> f TaskDesc -> Task f 'Finished
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
type CompletedTask = Task Identity Finished
deriving instance Eq CompletedTask
deriving instance Show CompletedTask
type CompletedTask = Task Identity 'Finished
-- InProgress, partially specified tasks
type InProgressPartialTask = Task Maybe InProgress
deriving instance Eq InProgressPartialTask
deriving instance Show InProgressPartialTask
type InProgressPartialTask = Task Maybe 'InProgress
-- InProgress, fully specified tasks
type InProgressTask = Task Identity InProgress
deriving instance Eq InProgressTask
deriving instance Show InProgressTask
type InProgressTask = Task Identity 'InProgress
-- Not started, partially specified tasks
type NotStartedPartialTask = Task Maybe NotStarted
deriving instance Eq NotStartedPartialTask
deriving instance Show NotStartedPartialTask
type NotStartedPartialTask = Task Maybe 'NotStarted
-- Not started, completely specified tasks
type NotStartedTask = Task Identity NotStarted
deriving instance Eq NotStartedTask
deriving instance Show NotStartedTask
type NotStartedTask = Task Identity 'NotStarted
----------------
-- Validation --
......@@ -73,7 +78,8 @@ deriving instance Show NotStartedTask
newtype FieldName = FieldName { getFieldName :: DT.Text } deriving (Eq, Show, Read)
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]
......@@ -98,12 +104,7 @@ class Validatable t where
validationChecks :: [ValidationCheck t]
type FullySpecifiedTask = Task Identity
deriving instance Eq (FullySpecifiedTask TaskState)
deriving instance Show (FullySpecifiedTask TaskState)
type PartialTask = Task Maybe
deriving instance Eq (PartialTask TaskState)
deriving instance Show (PartialTask TaskState)
taskNameField :: FieldName
taskNameField = FieldName "name"
......@@ -111,16 +112,21 @@ taskNameField = FieldName "name"
taskDescField :: FieldName
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
-- 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 = 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 = DT.strip . getTDesc . runIdentity . tDescription
fsTaskState :: FullySpecifiedTask TaskState -> TaskState
fsTaskState = runIdentity . tState
fsTaskDesc (FinishedT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskDesc (InProgressT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskDesc (NotStartedT _ (Identity desc)) = DT.strip $ getTDesc desc
instance Validatable (FullySpecifiedTask state) where
validationChecks = [checkName, checkDescription]
......@@ -132,10 +138,15 @@ instance Validatable (FullySpecifiedTask state) where
checkDescription t = if DT.null (fsTaskDesc t) then Just (InvalidField taskDescField) else Nothing
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 = (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
validationChecks = [checkName, checkDescription]
......@@ -174,11 +185,11 @@ instance Exception TaskStoreError
newtype TaskID = TaskID { getTaskID :: Int } deriving (Eq, Show, Read)
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))
getTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
updateTask :: c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
getTask :: forall (state :: TaskState). c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
updateTask :: forall (state :: TaskState). c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask :: forall (state :: TaskState). c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
data WithID a where
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