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.
-> IO (Either EntityStoreError (WithID ident (Complete entity)))
insertAndReturnEntity conn (WINT64 _ _) = pure $ Left $ UnexpectedErrorES "insertion with integer based UUIDs is not allowed"
insertAndReturnEntity conn entity@(WUUID uuid _) = insertEntity conn entity
-- | Right now only saving by UUID is allowed
>> 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
-- 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 (WUUID uuid v) = WID (Left uuid) v
uuidToGenericIdent (WID (Left uuid) v) = WID (Left uuid) v
instance SQLInsertable (Complete (Task state)) where
tableName = TN $ "tasks"
columnNames = SQLCN $ ["name", "desc", "state"]
tableName = TN "tasks"
columnNames = SQLCN ["name", "description", "state"]
-- | 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
instance forall e. SQLInsertable e => SQLInsertable (WithID 'UUIDID e) where
tableName = TN $ "tasks"
columnNames = SQLCN $ ["uuid"] ++ innerCols
tableName = TN "tasks"
columnNames = SQLCN $ "uuid":innerCols
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
-- All we do is ensure teh columns include an "id" at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where
tableName = TN $ "tasks"
columnNames = SQLCN $ ["id"] ++ innerCols
tableName = TN "tasks"
columnNames = SQLCN $ "id":innerCols
where
(SQLCN innerCols) = (columnNames :: SQLColumnNames e)
(SQLCN innerCols) = columnNames :: SQLColumnNames e
data QueryWithParams = QWP Query [SQLData]
......@@ -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
=> WithID ident (Complete entity)
-> QueryWithParams
buildInsertQuery e = makeInsertQuery tblName cNames e
buildInsertQuery = makeInsertQuery tblName cNames
where
tblName = tableName :: TableName (WithID ident (Complete entity))
cNames = columnNames :: SQLColumnNames (WithID ident (Complete entity))
......@@ -302,7 +299,7 @@ makeInsertQuery (TN tbl) (SQLCN colNames) entity = QWP insertQuery params
where
insertQuery = Query $ [text| INSERT INTO $tbl ( $columnPhrase ) VALUES ( $valueQs ) |]
columnPhrase = DT.intercalate "," colNames
valueQs = DT.intercalate "," $ take (length colNames) $ repeat "?"
valueQs = DT.intercalate "," $ replicate (length colNames) "?"
params = toRow entity
-- | Do the actual insertion for an entity
......@@ -320,20 +317,25 @@ insertEntity conn e@(WUUID uuid _) = Right <$> execute conn query params
-- | Retrieve an entity by UUID
getEntityByUUID :: forall entity.
( SQLInsertable entity
, FromRow entity
, FromRow (WithID 'UUIDID entity))
=> Connection
-> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID entity))
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])
-- >>= \(QWP q p) -> (query_ conn (Query "SELECT * FROM tasks LIMIT 1") :: IO [WithID 'UUIDID entity]) -- undefined -- q p
>>= \case
(x:_) -> pure $ Right x
-- 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
tableName = tableName :: TableName (WithID 'UUIDID 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))
where
uuidTxt = toText uuid
......@@ -348,7 +350,7 @@ instance SQLEntityStore SQLiteEntityStore where
-- | Generate an insert query for the `WithID entity`
>>= insertAndReturnEntity c
>>= 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
getByID store eid = undefined
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......@@ -216,10 +215,13 @@ data WithID (ident :: Identifier) a where
withoutID :: forall (ident :: Identifier) a. WithID ident a -> a
withoutID (WUUID _ a) = a
withoutID (WINT64 _ a) = a
withoutID (WID _ a) = a
showID :: forall (ident :: Identifier) a. WithID ident a -> String
showID (WUUID 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.
-- 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
>>= \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)
>>= shouldBe True
>>= \actualWithID -> pure ( showID actualWithID /= "" &&
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