Commit f1534073 authored by MrMan's avatar MrMan

Fix missing cases of Eq

parent 01a48ede
......@@ -74,7 +74,7 @@ instance FromField TaskDesc where
fromField = (TaskDesc <$>) . (fromField :: FieldParser DT.Text)
instance FromField TaskStateValue where
fromField = (TaskStateValue <$>) . (fromField :: FieldParser DT.Text)
fromField = (TSV <$>) . (fromField :: FieldParser DT.Text)
instance ToField TaskDesc where
toField = SQLText . getTDesc
......@@ -323,8 +323,8 @@ getEntityByUUID :: forall entity.
-> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID entity))
getEntityByUUID conn uuid = pure (makeSelectByUUIDQuery tableName uuid)
>>= \(QWP q p) -> (query conn q p :: IO [WithID 'UUIDID entity])
-- >>= \(QWP q p) -> (query_ conn (Query "SELECT * FROM tasks LIMIT 1") :: IO [WithID 'UUIDID entity]) -- undefined -- q p
-- >>= \(QWP q p) -> (query conn q p :: IO [WithID 'UUIDID entity])
>>= \(QWP q p) -> (query_ conn (Query "SELECT * FROM tasks LIMIT 1") :: IO [WithID 'UUIDID entity]) -- undefined -- q p
>>= \case
-- Not 100% percent sure which GADT constructor will get used (there might be a rule for this)
-- So I march all possible ways that a UUID thing comes back
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
......@@ -37,7 +38,7 @@ 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)
newtype TaskStateValue = TSV { getTStateLiteral :: DT.Text } deriving (Eq, Show)
-- The beefy task class
data Task (state :: TaskState) f where
......@@ -52,33 +53,33 @@ data Task (state :: TaskState) f where
UnknownStateT :: f TaskName -> f TaskDesc -> TaskStateValue -> Task state f
instance Eq (Task (state :: TaskState) Identity) where
a@(FinishedT n1 d1) == b@(FinishedT n2 d2) = n1 == n2 &&
d1 == d2
a@(InProgressT n1 d1) == b@(InProgressT n2 d2) = n1 == n2 &&
d1 == d2
a@(NotStartedT n1 d1) == b@(NotStartedT n2 d2) = n1 == n2 &&
d1 == d2
a@(UnknownStateT n1 d1 s1) == b@(UnknownStateT n2 d2 s2) = n1 == n2 &&
d1 == d2 &&
s1 == s2
(FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(InProgressT n1 d1) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(NotStartedT n1 d1) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "Finished")) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "InProgress")) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "NotStarted")) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 s1) == (UnknownStateT n2 d2 s2) = n1 == n2 &&
d1 == d2 &&
s1 == s2
_ == _ = False
instance Eq (Task (state :: TaskState) Maybe) where
a@(FinishedT n1 d1) == b@(FinishedT n2 d2) = n1 == n2 &&
d1 == d2
a@(InProgressT n1 d1) == b@(InProgressT n2 d2) = n1 == n2 &&
d1 == d2
a@(NotStartedT n1 d1) == b@(NotStartedT n2 d2) = n1 == n2 &&
d1 == d2
a@(UnknownStateT n1 d1 s1) == b@(UnknownStateT n2 d2 s2) = n1 == n2 &&
d1 == d2 &&
s1 == s2
(FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(InProgressT n1 d1) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(NotStartedT n1 d1) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "Finished")) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "InProgress")) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "NotStarted")) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 s1) == (UnknownStateT n2 d2 s2) = n1 == n2 &&
d1 == d2 &&
s1 == s2
_ == _ = False
resolveFinishedT :: forall (state :: TaskState) (f :: Type -> Type). Task state f -> Either ValidationError (Task 'Finished f)
resolveFinishedT (t@FinishedT{}) = Right t
resolveFinishedT (UnknownStateT name desc stateValue) = case stateValue of
(TaskStateValue "Finished") -> Right (FinishedT name desc)
(TSV "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)"
......
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