module Internal.Data.Basic.TH.Compiler where
import qualified Control.Lens.Internal.FieldTH as LTHI
import qualified Data.Text as T
import Internal.Interlude hiding (Type)
import Language.Haskell.TH hiding (Name)
import qualified Language.Haskell.TH.Syntax as TH
import Database.HsSqlPpp.Parse
import qualified Database.HsSqlPpp.Syntax as SQL
import Control.Effects.Signal
import qualified Internal.Data.Basic.TH.Generator as G
import Internal.Data.Basic.TH.Helper
import Internal.Data.Basic.TH.Types
import Internal.Data.Basic.TH.SqlToHsTypes
compileSQL :: Text -> Q (Either ParseError [SQL.Statement])
compileSQL filename = do
contents <- runIO $ liftIO $ readFile $ toS filename
return $ runIdentity (handleToEither $ liftError $ parseProcSQL defaultParseFlags (toS filename) Nothing (toS contents))
compileContext :: ParseContext -> Q [Dec]
compileContext c = do
let _entities = G.dataConstructor <$> c ^. entities
let result = concat $ compileEntity c <$> c ^. entities
let constraints = G.allConstraints c
let fieldOptics = G.fieldOptics (c ^. entities)
let fkOptics = G.fkOptics (c ^. fks)
let virtualFields = G.virtualTables (c ^. fks)
lenses <- concat <$> sequence (LTHI.makeFieldOpticsForDec lensRules <$> _entities)
let tableFields = G.tableFields (c ^. entities)
return $ concat [ _entities
, result
, constraints
, lenses
, tableFields
, fieldOptics
, fkOptics
, virtualFields]
compileEntity :: ParseContext -> EntityInfo -> [Dec]
compileEntity ctx info = G.tableInstance ctx info <>
[G.fromRowInstance name cols] <>
G.emptyEntity ctx info <>
G.initialAccessor info
where cols = info ^. entityInfoColumnMap
name = _entityInfoName info
compileSQLStatements :: (Throws ParseError m, MonadIO m)
=> ParseContext -> [SQL.Statement] -> m ParseContext
compileSQLStatements = foldlM compileSQLStatement
compileSQLStatement :: (Throws ParseError m, MonadIO m) => ParseContext -> SQL.Statement -> m ParseContext
compileSQLStatement initialCtx (SQL.CreateTable _ name attrs constraints _ _) = do
(ctx, ei) <- foldM (\(_ctx, _ei) attr -> updateContext _ctx entityName _ei attr) (initialCtx, entityInfo) attrs
finalCtx <- foldM (\_ctx c -> compileConstraint ctx ei c) ctx constraints
namedEi <- nameUnnamedConstraints ei
return $ finalCtx {_entities = finalCtx ^. entities <> [namedEi] }
where entityName = mkName (toS $ normalizeTable $ toS $ getName name)
n = toS $ getName name
entityInfo = EntityInfo n entityName name (ConT entityName) constraints mempty
compileSQLStatement ctx (SQL.AlterTable _ tableName (SQL.AlterTableActions _ l)) =
foldrM (\s _ctx -> handleAlterTableOperations _ctx tableName s) ctx l
compileSQLStatement ctx p = do
print $ "Compile error: only CREATE TABLE statement can be parsed " `T.append` show p
return ctx
handleAlterTableOperations :: Throws ParseError m
=> ParseContext -> SQL.Name -> SQL.AlterTableAction -> m ParseContext
handleAlterTableOperations ctx tableName (SQL.AddConstraint _ (SQL.PrimaryKeyConstraint _ name tables)) = do
fromEntity <- getEntityByName tableName (ctx ^. entities)
columns <- mapM (getColumn fromEntity) (toS. SQL.ncStr <$> tables)
return $ ctx & pks .~ (ctx ^. pks <> [PrimaryKeyConstraint (toS name) fromEntity columns])
handleAlterTableOperations ctx tableName (SQL.AddConstraint _ (SQL.UniqueConstraint _ name tables)) = do
fromEntity <- getEntityByName tableName (ctx ^. entities)
columns <- mapM (getColumn fromEntity) (toS. SQL.ncStr <$> tables)
return $ ctx & uqs .~ (ctx ^. uqs <> [UniqueKeyConstraint (toS name) fromEntity columns])
handleAlterTableOperations ctx tableName (SQL.AddConstraint _ (SQL.ReferenceConstraint _ refName fromTables toTable toTables _ _)) = do
toEntity <- getEntityByName toTable $ ctx ^. entities
fromEntity <- getEntityByName tableName (ctx ^. entities)
fromColumns <- mapM (getColumn fromEntity) (toS. SQL.ncStr <$> fromTables)
toColumns <- mapM (getColumn toEntity) (toS. SQL.ncStr <$> toTables)
return $ ctx & fks .~ (ctx ^. fks <> [ForeignKeyConstraint (toS refName) fromEntity fromColumns toEntity toColumns])
handleAlterTableOperations _ _ _ = throwSignal
$ ParseError "Compile error: only PRIMARY KEY, UNIQUE and FOREIGN KEY constraints are implemented"
updateContext :: Throws ParseError m => ParseContext -> TH.Name -> EntityInfo -> SQL.AttributeDef -> m (ParseContext, EntityInfo)
updateContext ctx entityName ei (SQL.AttributeDef _ nameC typ _ consts) = do
(columnHsType, constraints) <- toHsType typ
let g = ColumnInfo name normName (mkName (toS $ "_" <> lowerFirst (toS $ nameBase entityName) <> "_" <> name)) columnHsType typ constraints
(ctx2, ci) <- foldM (\(_ctx, _ci) cons -> compileRowConstraint _ctx ei _ci cons) (ctx, g) consts
return (ctx2, ei & entityInfoColumnMap .~ (ei ^. entityInfoColumnMap <> [ci]))
where name = toS $ SQL.ncStr nameC
normName = normalizeName name
compileRowConstraint :: Throws ParseError m => ParseContext -> EntityInfo -> ColumnInfo -> SQL.RowConstraint -> m (ParseContext, ColumnInfo)
compileRowConstraint ctx _ ci (SQL.NullConstraint _ _) = return (ctx, ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NullConstraint]))
compileRowConstraint ctx _ ci (SQL.NotNullConstraint _ _) = return (ctx, ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NotNullConstraint]))
compileRowConstraint ctx ei ci (SQL.RowUniqueConstraint _ name) = return (ctx & uqs .~ ( ctx ^. uqs <> [UniqueKeyConstraint (toS name) ei [ci]])
, ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NotNullConstraint]))
compileRowConstraint ctx ei ci (SQL.RowPrimaryKeyConstraint _ name) = return (ctx & pks .~ (ctx ^. pks <> [PrimaryKeyConstraint (toS name) ei [ci]])
, ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NotNullConstraint]))
compileRowConstraint ctx ei ci (SQL.RowReferenceConstraint a name toTable mToColumn _ _) = do
toEntityInfo <- getEntityByName toTable (ctx ^. entities)
toColumnInfo <- maybe (throwSignal $ ParseError err) (getColumn toEntityInfo . toS . SQL.ncStr) mToColumn
return (ctx & fks .~ (ctx ^. fks <> [ForeignKeyConstraint (toS name) ei [ci] toEntityInfo [toColumnInfo]]), ci)
where err = "Compile error: Unable to find column " <> show a
compileRowConstraint ctx _ ci _ = return (ctx, ci)
compileConstraint :: Throws ParseError m => ParseContext -> EntityInfo -> SQL.Constraint -> m ParseContext
compileConstraint ctx ei c = do
constraint <- nameUnnamedConstraint ei c
compileConstraint' ctx ei constraint
compileConstraint' :: Throws ParseError m => ParseContext -> EntityInfo -> SQL.Constraint -> m ParseContext
compileConstraint' ctx ei (SQL.UniqueConstraint _ name tables) = do
columnsInformation <- sequence $ getColumn ei <$> (toS. SQL.ncStr <$> tables)
return $ ctx & uqs .~ (ctx ^. uqs <> [UniqueKeyConstraint (toS name) ei columnsInformation])
compileConstraint' ctx ei (SQL.PrimaryKeyConstraint _ name tables) = do
columnsInformation <- sequence $ getColumn ei <$> (toS. SQL.ncStr <$> tables)
return $ ctx & pks .~ (ctx ^. pks <> [PrimaryKeyConstraint (toS name) ei columnsInformation])
compileConstraint' ctx ei (SQL.ReferenceConstraint _ name fromTables toTableName toTables _ _) = do
fromColumnsInfo <- sequence $ getColumn ei <$> (toS. SQL.ncStr <$> fromTables)
toEntityInfo <- getEntityByName toTableName (ctx ^. entities)
toColumnsInfo <- sequence $ getColumn toEntityInfo <$> (toS. SQL.ncStr <$> toTables)
return $ ctx & fks .~ (ctx ^. fks <> [ForeignKeyConstraint (toS name) ei fromColumnsInfo toEntityInfo toColumnsInfo])
compileConstraint' _ _ a = throwSignal $ ParseError $ "Compile error: constraint not supported " <> show a