module Internal.Data.Basic.TH.Generator where
import Internal.Interlude
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]
[DerivClause Nothing [ConT ''Show, ConT ''Read, ConT ''Generic]]
where entityName = _entityInfoName info
fields = (\c -> (c ^. columnInfoName, Bang SourceUnpack SourceStrict, finalType c)) <$> (info ^. entityInfoColumnMap)
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))
fieldOptics :: [EntityInfo] -> [TH.Dec]
fieldOptics em = concat $ fieldOptic <$> columnNames
where columnNames = nub $ _columnInfoNormalName <$> concat (_entityInfoColumnMap <$> em)
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 o = mkName "o"
fieldName = mkName $ toS t
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
fieldConstraint (SQL.ReferenceConstraint _ _ _ _ _ _ _) = Nothing
tableField :: EntityInfo -> ColumnInfo -> Dec
tableField ei ci = InstanceD Nothing [] (
AppT (ConT ''BT.TableField `AppT` ConT entityName)
(LitT $ StrTyLit $ toS normalName)
)
[ TySynInstD ''BT.TableFieldType $ TySynEqn
[ConT entityName, LitT $ StrTyLit $ toS normalName]
columnType
, TySynInstD ''BT.TableFieldCapsName $ TySynEqn
[ConT entityName, LitT $ StrTyLit $ toS normalName]
(PromotedT 'Just `AppT` LitT (StrTyLit (toS columnText)))
, FunD 'BT.tableFieldLens [Clause [] (NormalB $ VarE lensName) []]
]
where entityName = ei ^. entityInfoName
columnType = finalType ci
columnText = ci ^. columnInfoText
normalName = ci ^. columnInfoNormalName
lensName = mkName $ toS ((lowerFirst.normalizeTable $ ei ^. entityInfoText) <> "_" <> columnText)
tableFields :: [EntityInfo] -> [TH.Dec]
tableFields eis = concat ((\ei -> tableField ei <$> ei ^. entityInfoColumnMap) <$> eis)
finalType :: ColumnInfo -> TH.Type
finalType ci
| null (ci ^. columnInfoConstraints) = ConT ''Maybe `AppT` (ci ^. columnInfoType)
| otherwise = foldr (applyConstraint ci) (ci ^. columnInfoType) (ci ^. columnInfoConstraints)
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 = normalizeTable (toS tableName)
res = mkName "res"
accessor = mkName $ toS $ "all" <> quasyPlural sTableName
tableName = ei ^. entityInfoText
tableType = ei ^. entityInfoType
fkOptics :: [ForeignKeyConstraint] -> [Dec]
fkOptics = foldl' (\acc f -> fkOptic f <> acc) mempty
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
virtualTables :: [ForeignKeyConstraint] -> [Dec]
virtualTables = foldl' (\acc f -> acc <> virtualTable f) mempty
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
allConstraints :: ParseContext -> [Dec]
allConstraints ctx = concat ((uniqueConstraintInstance <$> ctx ^. uqs) <>
(primaryKeyInstance <$> ctx ^. pks) <>
[foreignKeyConstraint <$> ctx ^. fks])
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) <$> (_columnInfoNormalName <$> (uq ^. uqCols))
primaryKeyInstance :: PrimaryKeyConstraint -> [Dec]
primaryKeyInstance (PrimaryKeyConstraint name entity cols) = uniqueConstraintInstance (UniqueKeyConstraint name entity cols) <> [InstanceD Nothing [] (AppT (ConT ''BT.PrimaryKeyConstraint) (LitT (StrTyLit $ toS name))) []]
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 . _columnInfoNormalName <$> fromCol)),
TySynInstD ''BT.ForeignKeyTo $ TySynEqn [constraint] (toTableT ^. entityInfoType),
TySynInstD ''BT.ForeignKeyToFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoNormalName <$> toCol))
]
where constraint = LitT $ StrTyLit $ toS name
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 columnInfoNormalName <$> 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 = getDynamicDefaultColumns ctx ei
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" <> normalizeTable name
name = ei ^. entityInfoText
requiredFields = ei ^. entityInfoColumnMap \\ optionalCols
reqs = required requiredFields <> dynamicDefault optionalCols
optionalCols = getDynamicDefaultColumns ctx ei
required :: [ColumnInfo] -> [TH.Type]
required cs = f <$> cs
where f ci = ConT 'BT.Required `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoNormalName)
dynamicDefault :: [ColumnInfo] -> [TH.Type]
dynamicDefault cs = f <$> cs
where f ci = ConT 'BT.DynamicDefault `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoNormalName)
applyConstraint :: ColumnInfo -> ColumnConstraint -> TH.Type -> TH.Type
applyConstraint _ NullConstraint t = AppT (ConT ''Maybe) t
applyConstraint _ _ t = t
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)
schemaValue :: Text -> Text -> [Dec]
schemaValue name text =
[ SigD sname (ConT ''Schema)
, ValD (VarP sname) (NormalB (ConE 'Schema `AppE` LitE (StringL (toS text)))) [] ]
where
sname = mkName (toS name <> "Schema")