Commit 01a48ede authored by MrMan's avatar MrMan

Add hlint config, start trying to fix up tests

parent 3d3aea57
# HLint configuration file
##########################
- arguments: [--color]
- functions:
- {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
- ignore: {name: Use fmap}
- ignore: {name: Use <$>}
...@@ -252,36 +252,33 @@ insertAndReturnEntity :: forall (ident :: Identifier) entity. ...@@ -252,36 +252,33 @@ insertAndReturnEntity :: forall (ident :: Identifier) entity.
-> IO (Either EntityStoreError (WithID ident (Complete entity))) -> IO (Either EntityStoreError (WithID ident (Complete entity)))
insertAndReturnEntity conn (WINT64 _ _) = pure $ Left $ UnexpectedErrorES "insertion with integer based UUIDs is not allowed" insertAndReturnEntity conn (WINT64 _ _) = pure $ Left $ UnexpectedErrorES "insertion with integer based UUIDs is not allowed"
insertAndReturnEntity conn entity@(WUUID uuid _) = insertEntity conn entity insertAndReturnEntity conn entity@(WUUID uuid _) = insertEntity conn entity
-- | Right now only saving by UUID is allowed
>> getEntityByUUID conn uuid >> getEntityByUUID conn uuid
>>= rightOrThrow
-- | We need to obscure the type to match for "any" ident
>>= pure . Right . uuidToGenericIdent
-- | Convert an type-specified identifier to a generic one identifier to a generic one -- | Convert an type-specified identifier to a generic one identifier to a generic one
-- This is necessary when interfaces need the generic version but haskell is smart enough to know which is there and can't unify them -- This is necessary when interfaces need the generic version but haskell is smart enough to know which is there and can't unify them
uuidToGenericIdent :: forall (ident :: Identifier) e. WithID 'UUIDID e -> WithID ident e uuidToGenericIdent :: forall (ident :: Identifier) e. WithID 'UUIDID e -> WithID ident e
uuidToGenericIdent (WUUID uuid v) = WID (Left uuid) v uuidToGenericIdent (WUUID uuid v) = WID (Left uuid) v
uuidToGenericIdent (WID (Left uuid) v) = WID (Left uuid) v
instance SQLInsertable (Complete (Task state)) where instance SQLInsertable (Complete (Task state)) where
tableName = TN $ "tasks" tableName = TN "tasks"
columnNames = SQLCN $ ["name", "desc", "state"] columnNames = SQLCN ["name", "description", "state"]
-- | If some value e is SQLInsertable, then the same value with a UUID is insertable -- | If some value e is SQLInsertable, then the same value with a UUID is insertable
-- All we do is ensure the columns include a "uuid" column at the beginning -- All we do is ensure the columns include a "uuid" column at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'UUIDID e) where instance forall e. SQLInsertable e => SQLInsertable (WithID 'UUIDID e) where
tableName = TN $ "tasks" tableName = TN "tasks"
columnNames = SQLCN $ ["uuid"] ++ innerCols columnNames = SQLCN $ "uuid":innerCols
where where
(SQLCN innerCols) = (columnNames :: SQLColumnNames e) (SQLCN innerCols) = columnNames :: SQLColumnNames e
-- | If some value e is insertable in the SQL paradigm, then the same value with an ID is insertable -- | If some value e is insertable in the SQL paradigm, then the same value with an ID is insertable
-- All we do is ensure teh columns include an "id" at the beginning -- All we do is ensure teh columns include an "id" at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where
tableName = TN $ "tasks" tableName = TN "tasks"
columnNames = SQLCN $ ["id"] ++ innerCols columnNames = SQLCN $ "id":innerCols
where where
(SQLCN innerCols) = (columnNames :: SQLColumnNames e) (SQLCN innerCols) = columnNames :: SQLColumnNames e
data QueryWithParams = QWP Query [SQLData] data QueryWithParams = QWP Query [SQLData]
...@@ -291,7 +288,7 @@ buildInsertQuery :: forall (ident :: Identifier) (entity :: FBounded). -- | poly ...@@ -291,7 +288,7 @@ buildInsertQuery :: forall (ident :: Identifier) (entity :: FBounded). -- | poly
SQLInsertable (WithID ident (Complete entity))) -- | entity must be insertable under SQL & complete w/ an ID SQLInsertable (WithID ident (Complete entity))) -- | entity must be insertable under SQL & complete w/ an ID
=> WithID ident (Complete entity) => WithID ident (Complete entity)
-> QueryWithParams -> QueryWithParams
buildInsertQuery e = makeInsertQuery tblName cNames e buildInsertQuery = makeInsertQuery tblName cNames
where where
tblName = tableName :: TableName (WithID ident (Complete entity)) tblName = tableName :: TableName (WithID ident (Complete entity))
cNames = columnNames :: SQLColumnNames (WithID ident (Complete entity)) cNames = columnNames :: SQLColumnNames (WithID ident (Complete entity))
...@@ -302,7 +299,7 @@ makeInsertQuery (TN tbl) (SQLCN colNames) entity = QWP insertQuery params ...@@ -302,7 +299,7 @@ makeInsertQuery (TN tbl) (SQLCN colNames) entity = QWP insertQuery params
where where
insertQuery = Query $ [text| INSERT INTO $tbl ( $columnPhrase ) VALUES ( $valueQs ) |] insertQuery = Query $ [text| INSERT INTO $tbl ( $columnPhrase ) VALUES ( $valueQs ) |]
columnPhrase = DT.intercalate "," colNames columnPhrase = DT.intercalate "," colNames
valueQs = DT.intercalate "," $ take (length colNames) $ repeat "?" valueQs = DT.intercalate "," $ replicate (length colNames) "?"
params = toRow entity params = toRow entity
-- | Do the actual insertion for an entity -- | Do the actual insertion for an entity
...@@ -320,20 +317,25 @@ insertEntity conn e@(WUUID uuid _) = Right <$> execute conn query params ...@@ -320,20 +317,25 @@ insertEntity conn e@(WUUID uuid _) = Right <$> execute conn query params
-- | Retrieve an entity by UUID -- | Retrieve an entity by UUID
getEntityByUUID :: forall entity. getEntityByUUID :: forall entity.
( SQLInsertable entity ( SQLInsertable entity
, FromRow entity
, FromRow (WithID 'UUIDID entity)) , FromRow (WithID 'UUIDID entity))
=> Connection => Connection
-> UUID -> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID entity)) -> IO (Either EntityStoreError (WithID 'UUIDID entity))
getEntityByUUID conn uuid = pure (makeSelectByUUIDQuery tableName uuid) getEntityByUUID conn uuid = pure (makeSelectByUUIDQuery tableName uuid)
>>= \(QWP q p) -> query conn q p >>= \(QWP q p) -> (query conn q p :: IO [WithID 'UUIDID entity])
>>= \case -- >>= \(QWP q p) -> (query_ conn (Query "SELECT * FROM tasks LIMIT 1") :: IO [WithID 'UUIDID entity]) -- undefined -- q p
(x:_) -> pure $ Right x >>= \case
_ -> pure $ Left $ NoSuchEntityES (Left uuid) "Failed to find task with given UUID" -- 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
(v@WUUID{}:_) -> pure $ Right v
(v@(WID (Left uuid) inner):_) -> pure $ Right $ WID (Left uuid) inner
_ -> pure $ Left $ NoSuchEntityES (Left uuid) "Failed to find task with given UUID"
where where
tableName = tableName :: TableName (WithID 'UUIDID entity) tableName = tableName :: TableName (WithID 'UUIDID entity)
-- | Create the select query for an entity -- | Create the select query for an entity
makeSelectByUUIDQuery :: (SQLInsertable entity) => TableName entity -> UUID -> QueryWithParams makeSelectByUUIDQuery :: SQLInsertable entity => TableName entity -> UUID -> QueryWithParams
makeSelectByUUIDQuery (TN tbl) uuid = QWP query (toRow (Only uuid)) makeSelectByUUIDQuery (TN tbl) uuid = QWP query (toRow (Only uuid))
where where
uuidTxt = toText uuid uuidTxt = toText uuid
...@@ -348,7 +350,7 @@ instance SQLEntityStore SQLiteEntityStore where ...@@ -348,7 +350,7 @@ instance SQLEntityStore SQLiteEntityStore where
-- | Generate an insert query for the `WithID entity` -- | Generate an insert query for the `WithID entity`
>>= insertAndReturnEntity c >>= insertAndReturnEntity c
>>= rightOrThrow >>= rightOrThrow
-- | Need to obscure the ident type here because ghc knows it can only be UUID -- | We need to obscure the type to match for "any" ident
>>= pure . Right . uuidToGenericIdent >>= pure . Right . uuidToGenericIdent
getByID store eid = undefined getByID store eid = undefined
......
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
...@@ -216,10 +215,13 @@ data WithID (ident :: Identifier) a where ...@@ -216,10 +215,13 @@ data WithID (ident :: Identifier) a where
withoutID :: forall (ident :: Identifier) a. WithID ident a -> a withoutID :: forall (ident :: Identifier) a. WithID ident a -> a
withoutID (WUUID _ a) = a withoutID (WUUID _ a) = a
withoutID (WINT64 _ a) = a withoutID (WINT64 _ a) = a
withoutID (WID _ a) = a
showID :: forall (ident :: Identifier) a. WithID ident a -> String showID :: forall (ident :: Identifier) a. WithID ident a -> String
showID (WUUID v _) = show v showID (WUUID v _) = show v
showID (WINT64 v _) = show v showID (WINT64 v _) = show v
showID (WID (Left v) _) = show v
showID (WID (Right v) _) = show v
-- | A typeclass consisting of types that can produce an ID usable by a SQL library to represent itself. -- | A typeclass consisting of types that can produce an ID usable by a SQL library to represent itself.
-- for example, if SQL library a can take `Int` for numeric IDs as well as `String`s for UUIDs, and id is an abstraction over both forms of ID, -- for example, if SQL library a can take `Int` for numeric IDs as well as `String`s for UUIDs, and id is an abstraction over both forms of ID,
......
...@@ -65,5 +65,6 @@ spec = do ...@@ -65,5 +65,6 @@ spec = do
>>= \expected -> create store (expected :: Validated NotStartedTask) >>= \expected -> create store (expected :: Validated NotStartedTask)
>>= rightOrThrow >>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right -- | 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) >>= \actualWithID -> pure ( showID actualWithID /= "" &&
>>= shouldBe True withoutID actualWithID == getValidatedObj expected )
>>= (`shouldBe` True)
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