Commit 3d3aea57 authored by MrMan's avatar MrMan

Remove some leftover example code, start writing tests

parent 29ce99e9
......@@ -122,30 +122,6 @@ instance FromField TaskState where
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 FromRow (FullySpecifiedTask 'NotStarted) where
fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "NotStarted") -> pure (NotStartedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
disconnectionError :: IO (Either EntityStoreError a)
disconnectionError = pure $ Left $ DisconnectedES "Store is disconnected"
......
......@@ -52,6 +52,30 @@ data Task (state :: TaskState) f where
-- 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 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
_ == _ = 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
_ == _ = 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
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
module Components.EntityStore.SQLiteSpec (spec) where
......@@ -6,7 +7,7 @@ import Components.EntityStore.SQLite (SQLiteEntityStore)
import Types ( Constructable(..)
, HasMigratableDB(..)
, ValidationError
, EntityStore(..)
, SQLEntityStore(..)
, EntityStoreError
, SQLMigrationVersion(..)
, Validated
......@@ -17,6 +18,7 @@ import Types ( Constructable(..)
, Task(..)
, TaskName(..)
, TaskDesc(..)
, Complete
, WithID
, withoutID
, showID
......@@ -34,33 +36,33 @@ makeDefaultStore :: IO (Either EntityStoreError SQLiteEntityStore)
makeDefaultStore = construct defaultCompleteEntityStoreConfig
-- generateTask :: IO (Validated NotStartedTask)
generateTask :: IO (Validated (Task Identity TaskState))
generateTask = rightOrThrow $ validate Task { tName = Identity $ TaskName "example"
, tDescription = Identity $ TaskDesc "this is a example task"
, tState = Identity NotStarted
}
generateTask :: IO (Validated NotStartedTask)
generateTask = rightOrThrow $ validate $ NotStartedT name desc
where
name = Identity $ TaskName "example"
desc = Identity $ TaskDesc "this is a example task"
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "task store creation" $
describe "entity store creation" $
it "works with the default config" $ \_ -> liftIO makeDefaultStore
>>= (`shouldBe` True) . isRight
describe "task store migration" $
describe "entity store migration" $
it "migrates with the default config (0 -> 1)" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= liftIO . migrate
>>= shouldBe (Right ())
describe "task store persistTask" $
describe "entity store create" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> persistTask store expected
>>= \expected -> create store (expected :: Validated NotStartedTask)
>>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right
>>= \actualWithID -> pure (showID actualWithID /= "" && withoutID actualWithID == getValidatedObj expected)
......
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