module Internal.Data.Basic.TH.Generator where
import Internal.Interlude
import Cases
import Internal.Data.Basic.TH.Types
import Data.List (nub, (\\))
import qualified Internal.Data.Basic.Types as BT
import qualified Internal.Data.Basic as B
import qualified Internal.Data.Basic.Foreign as F
import Language.Haskell.TH.Syntax as TH
import qualified Database.HsSqlPpp.Syntax as SQL
import Internal.Data.Basic.TH.Helper
import Internal.Data.Basic.Virtual
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.FromRow
import GHC.Generics (Generic)
dataConstructor :: EntityInfo -> TH.Dec
dataConstructor info = DataD [] entityName [] Nothing [RecC entityName fields] [ConT ''Show, ConT ''Read, ConT ''Generic]
where entityName = _entityInfoName info
fields = (\c -> (c ^. columnInfoName, Bang SourceUnpack SourceStrict, finalType c)) <$> (info ^. entityInfoColumnMap)
-- | Generates a fromRow instance for a entity.
--
-- > instance FromRow Post where
-- > fromRow = Post <$> field <*> field <*> field
--
-- fromRowInstance takes a name of the entity and a list of [a],
-- which is just used to count how many fields does the entity have - nothing
-- else. It generates something similar shown in a code snippet above - a
-- working FromRow instance for that datatype.
fromRowInstance :: TH.Name -> [a] -> TH.Dec
fromRowInstance entityName fields = InstanceD Nothing [] (AppT (ConT ''FromRow)
(ConT entityName))
[ValD (VarP 'fromRow)
(NormalB (addFields initial n)) []]
where n = length fields
initial = InfixE (Just (ConE entityName))
(VarE '(<$>))
(Just (VarE 'field))
-- | Generates field optics for all entities
fieldOptics :: [EntityInfo] -> [TH.Dec]
fieldOptics em = concat $ fieldOptic <$> columnNames
where columnNames = nub $ _columnInfoText <$> concat (_entityInfoColumnMap <$> em)
-- | Generates field optics for a column
--
--
-- > name :: (FieldOptic "username" fun inType outType inVal outVal) => PolyOptic fun inType outType inVal outVal
-- > name = fieldOpticProxy (Proxy :: Proxy "username")
--
--
fieldOptic :: Text -> [Dec]
fieldOptic t = [SigD fieldName (
ForallT [PlainTV o]
[
AppT (ConT ''B.FieldOpticProxy)
(AppT (AppT ArrowT
(AppT (ConT ''Proxy)
(LitT (StrTyLit $ toS t))))
(VarT o))
]
(VarT o)),
ValD (VarP fieldName) (
NormalB (AppE (VarE 'B.fieldOpticProxy)
(SigE (ConE 'Proxy)
(AppT (ConT ''Proxy)
(LitT (StrTyLit $ toS t)))))) []
]
where fieldName = mkName $ toS $ camelize t
o = mkName "o"
-- | Applies basic constraint depending on sql constraint
-- If columns is marked as primary or unique, add the 'Unique' haskell datatype
fieldConstraint :: SQL.Constraint -> Maybe [TH.Type]
fieldConstraint (SQL.UniqueConstraint _ name _) = Just [ConT 'BT.Unique `AppT` (LitT $ StrTyLit $ toS name)]
fieldConstraint (SQL.PrimaryKeyConstraint _ name _) = Just [ConT 'BT.Unique `AppT` (LitT $ StrTyLit $ toS name)]
fieldConstraint (SQL.CheckConstraint _ _ _) = Nothing -- @TODO dependent types? :)
fieldConstraint (SQL.ReferenceConstraint _ _ _ _ _ _ _) = Nothing -- @TODO foreign keys?
-- | Generates a table field instance for a column
--
-- > instance TableField Post "user_id" where
-- > type TableFieldType Post "user_id" = Key
-- > tableFieldLens = ostUserId
--
tableField :: EntityInfo -> ColumnInfo -> Dec
tableField ei ci = InstanceD Nothing [] (
AppT (ConT ''BT.TableField `AppT` (ConT entityName))
(LitT $ StrTyLit $ toS columnText)
) [
TySynInstD ''BT.TableFieldType $ TySynEqn
[ConT entityName, LitT $ StrTyLit $ toS columnText]
columnType,
FunD 'BT.tableFieldLens [Clause [] (NormalB $ VarE lensName) []]
]
where entityName = ei ^. entityInfoName
columnType = finalType ci
columnText = ci ^. columnInfoText
lensName = mkName $ toS ((lowerFirst.standardizeName $ ei ^. entityInfoText) <> "_" <> columnText)
-- | Generates required table field instances for all entities
tableFields :: [EntityInfo] -> [TH.Dec]
tableFields eis = concat ((\ei -> tableField ei <$> ei ^. entityInfoColumnMap) <$> eis)
-- | Generates final type for the sql column
finalType :: ColumnInfo -> TH.Type
finalType ci
| null (ci ^. columnInfoConstraints) = ConT ''Maybe `AppT` (ci ^. columnInfoType)
| otherwise = foldr (applyConstraint ci) (ci ^. columnInfoType) (ci ^. columnInfoConstraints)
-- | Generates initial accessor for the table
--
-- > allPosts = allRows (Proxy :: Proxy "post")
--
initialAccessor :: EntityInfo -> [TH.Dec]
initialAccessor ei =
[ SigD accessor
(ForallT [PlainTV res]
[ConT ''B.AllRows `AppT` tableType `AppT` VarT res]
(VarT res))
, FunD accessor
[Clause []
(NormalB (AppE (VarE 'B.allRowsProxy)
(SigE (ConE 'Proxy) (ConT ''Proxy `AppT` tableType))))
[]] ]
where sTableName = standardizeName (toS tableName)
res = mkName "res"
accessor = mkName $ toS $ "all" <> quasyPlural sTableName
tableName = ei ^. entityInfoText
tableType = ei ^. entityInfoType
-- | Generates foreign key optics
fkOptics :: [ForeignKeyConstraint] -> [Dec]
fkOptics = foldl' (\acc f -> fkOptic f <> acc) mempty
-- | Generates foreign key optic
--
-- > author :: ForeignKeyLensProxy (Proxy "blog_post_author_fkey" -> o) => o
-- > author = foreignKeyLens @"blog_post_author_fkey"
--
fkOptic :: ForeignKeyConstraint -> [Dec]
fkOptic fk = [
SigD accName (ForallT [PlainTV o] [
AppT (ConT ''F.ForeignKeyLensProxy)
(AppT (ArrowT `AppT` (ConT ''Proxy `AppT` name))
(VarT o))] (VarT o)),
ValD (VarP accName)
(NormalB (AppE (VarE 'B.foreignKeyLensProxy)
(SigE (ConE 'Proxy) (ConT ''Proxy `AppT` name)))) []]
where accName = mkName $ toS $ (lowerFirst $ toS $ nameBase $ _entityInfoName (_fkFromT fk)) <> (toS $ nameBase $ _entityInfoName (_fkToT fk))
o = mkName "o"
name = LitT $ StrTyLit $ toS $ fk ^. fkName
-- | Generates virtual table optics
virtualTables :: [ForeignKeyConstraint] -> [Dec]
virtualTables = foldl' (\acc f -> acc <> virtualTable f) mempty
-- | Generates virtual table optic
--
-- > posts :: VirtualTable "blog_post_author_fkey" res
-- > => Getter' (Entity ('FromDb c) (ForeignKeyTo "blog_post_author_fkey")) res
-- > posts = virtualTableLensProxy (Proxy :: Proxy "blog_post_author_fkey")
--
virtualTable :: ForeignKeyConstraint -> [Dec]
virtualTable fk = [
SigD accName (ForallT [PlainTV o,PlainTV c_1] [
(ConT ''VirtualTable `AppT` name) `AppT` VarT o
]
(AppT (AppT (ConT ''B.Getter')
(AppT (AppT (ConT ''BT.Entity)
(PromotedT 'BT.FromDb `AppT` VarT c_1))
(ConT ''BT.ForeignKeyTo `AppT` name)))
(VarT o))),
ValD (VarP accName) (NormalB (AppE (VarE 'B.virtualTableLensProxy)
(SigE (ConE 'Proxy) (ConT ''Proxy `AppT` name))))
[]]
where accName = mkName $ toS $ (lowerFirst $ toS $ nameBase $ _entityInfoName (_fkToT fk)) <> (toS $ nameBase $ _entityInfoName (_fkFromT fk))
o = mkName "o"
c_1 = mkName "c1"
name = LitT $ StrTyLit $ toS $ fk ^. fkName
-- | Generates all constraint declarations from the 'ParseContext'
allConstraints :: ParseContext -> [Dec]
allConstraints ctx = concat ((uniqueConstraintInstance <$> ctx ^. uqs) <>
(primaryKeyInstance <$> ctx ^. pks) <>
[foreignKeyConstraint <$> ctx ^. fks])
-- | Generates unique key constraint instance
--
-- > instance UniqueConstraint "blog_user_pkey" where
-- > type UniqueTable "blog_user_pkey" = User
-- > type UniqueFields "blog_user_pkey" = '["id"]
--
uniqueConstraintInstance :: UniqueKeyConstraint -> [Dec]
uniqueConstraintInstance uq = [
InstanceD Nothing [] (
AppT (ConT ''BT.UniqueConstraint) (LitT (StrTyLit keyName))
) [
TySynInstD ''BT.UniqueTable (
TySynEqn [LitT (StrTyLit keyName)] (ConT entityName)),
TySynInstD ''BT.UniqueFields (
TySynEqn [LitT (StrTyLit keyName)] (listToTypeLevel cols))]]
where keyName = toS $ uq ^. uqName
ei = uq ^. uqEntity
entityName = ei ^. entityInfoName
cols = (LitT . StrTyLit . toS) <$> (_columnInfoText <$> (uq ^. uqCols))
-- | Generates primary key instance
--
-- > instance PrimaryKeyConstraint "blog_user_pkey"
--
primaryKeyInstance :: PrimaryKeyConstraint -> [Dec]
primaryKeyInstance (PrimaryKeyConstraint name entity cols) = uniqueConstraintInstance (UniqueKeyConstraint name entity cols) <> [InstanceD Nothing [] (AppT (ConT ''BT.PrimaryKeyConstraint) (LitT (StrTyLit $ toS name))) []]
-- | Generates foreign key instance
--
-- > instance ForeignKeyConstraint "blog_post_author_fkey" where
-- > type ForeignKeyFrom "blog_post_author_fkey" = Post
-- > type ForeignKeyFromFields "blog_post_author_fkey" = '["author"]
-- > type ForeignKeyTo "blog_post_author_fkey" = User
-- > type ForeignKeyToFields "blog_post_author_fkey" = '["id"]
--
foreignKeyConstraint :: ForeignKeyConstraint -> Dec
foreignKeyConstraint (ForeignKeyConstraint name fromTableT fromCol toTableT toCol) = InstanceD Nothing [] (ConT ''BT.ForeignKeyConstraint `AppT` (LitT $ StrTyLit $ toS name)) [
TySynInstD ''BT.ForeignKeyFrom $ TySynEqn [constraint] (fromTableT ^. entityInfoType),
TySynInstD ''BT.ForeignKeyFromFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoText <$> fromCol)),
TySynInstD ''BT.ForeignKeyTo $ TySynEqn [constraint] (toTableT ^. entityInfoType),
TySynInstD ''BT.ForeignKeyToFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoText <$> toCol))
]
where constraint = LitT $ StrTyLit $ toS name
-- | Generates a table instance for an entity from a 'ParseContext'
--
-- > instance Table Post where
-- > type TableName Post = "blog_post"
-- > type TableFields Post = ["id", "name", "author"]
-- > type TableConstraints Post = '[]
-- > type TablePrimaryKey Post = 'Nothing
-- > type TableRequiredFields Post = ['DynamicDefault 'id, 'Required "name", 'Required "author"]
--
tableInstance :: ParseContext -> EntityInfo -> [Dec]
tableInstance ctx ei = [
InstanceD Nothing [] (ConT ''BT.Table `AppT` entityType) [
TySynInstD ''BT.TableName $ TySynEqn [entityType] (LitT $ StrTyLit tableName),
TySynInstD ''BT.TableFields $ TySynEqn [entityType] entityFields,
TySynInstD ''BT.TableConstraints $ TySynEqn [entityType] entityConstraints,
TySynInstD ''BT.TablePrimaryKey $ TySynEqn [entityType] primaryKey,
TySynInstD ''BT.TableRequiredFields $ TySynEqn [entityType] tableRequirements,
ValD (VarP 'BT.newEntity) (coerceBody ei) []
]
]
where fieldNames = view columnInfoText <$> columns
columns = ei ^. entityInfoColumnMap
constraints = ei ^. entityInfoConstraintList
entityType = ei ^. entityInfoType
tableName = toS $ ei ^. entityInfoText
entityFields = listToTypeLevel $ LitT . StrTyLit . toS <$> fieldNames
entityConstraints = listToTypeLevel $ (concat.catMaybes) (fieldConstraint <$> constraints)
primaryKey = maybe (ConT 'Nothing) (AppT (ConT 'Just) . LitT . StrTyLit . toS . _pkName) (getEntityPrimaryKey ctx ei)
requiredFields = ei ^. entityInfoColumnMap \\ optionalCols
tableRequirements = listToTypeLevel $ required requiredFields <> dynamicDefault optionalCols
optionalCols = getOptionalColumns ctx ei
-- | Generates a empty entity
--
-- > newPost = Entity ('Fresh ['DynamicDefault "id", 'Required "name", 'Required "author"])
-- > newPost = Entity (Post 1 "" 1)
--
emptyEntity :: ParseContext -> EntityInfo -> [Dec]
emptyEntity ctx ei = [
SigD fname (AppT (AppT (ConT ''BT.Entity)
(PromotedT 'BT.Fresh `AppT` listToTypeLevel reqs))
(ei ^. entityInfoType)),
ValD (VarP fname) (coerceBody ei) []]
where fname = mkName $ toS $ "new" <> standardizeName name
name = ei ^. entityInfoText
requiredFields = ei ^. entityInfoColumnMap \\ optionalCols
reqs = required requiredFields <> dynamicDefault optionalCols
optionalCols = getOptionalColumns ctx ei
-- | Applies 'Required' constraint to list of columns
required :: [ColumnInfo] -> [TH.Type]
required cs = f <$> cs
where f ci = ConT 'BT.Required `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoText)
-- | Applies 'DynamicDefault' constraint to a list of columns
dynamicDefault :: [ColumnInfo] -> [TH.Type]
dynamicDefault cs = f <$> cs
where f ci = ConT 'BT.DynamicDefault `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoText)
-- | Modifies column type depending on column constraints
applyConstraint :: ColumnInfo -> ColumnConstraint -> TH.Type -> TH.Type
applyConstraint _ NullConstraint t = AppT (ConT ''Maybe) t
applyConstraint _ _ t = t
-- | Generates coerce body. See 'NullValue' why this is needed
coerceBody :: EntityInfo -> TH.Body
coerceBody ei = NormalB (AppE (ConE 'BT.Entity ) (nullValue' n $ ConE name))
where n = length $ ei ^. entityInfoColumnMap
name = ei ^. entityInfoName
nullValue' :: Int -> TH.Exp -> TH.Exp
nullValue' 0 initial = initial
nullValue' n initial = AppE (nullValue' (n - 1) initial) (VarE 'nullValue)