hesql-0.5: HESQL/Translator.hs
module HESQL.Translator (generateCode) where
import Language.Haskell.Syntax
import Database.HDBC.PostgreSQL
import HESQL.Syntax
import HESQL.Verifier
import System.FilePath
import Database.HsSqlPpp.PrettyPrinter.PrettyPrinter
import Database.HsSqlPpp.Ast.Ast
import Data.List (elemIndex)
stmtRec = HsIdent "Stmts"
funarg = HsPVar . HsIdent
funargs = map funarg
srcloc = SrcLoc "<dummy>" 1 1
hsSimpleFun name vars body wheres =
HsFunBind [HsMatch srcloc (HsIdent name) (funargs vars) body wheres]
generateCode :: FilePath -> String -> HesqlModule -> IO HsModule
generateCode fn db (HesqlModule modName decls) = do
conn <- connectPostgreSQL db
mapM_ (verifySql conn . declSQL) decls'
return $ HsModule srcloc (Module modName) Nothing imports hsDecls
where imports = [HsImportDecl srcloc (Module "Database.HDBC")
False Nothing Nothing]
hsDecls = [dataType, initFun decls'] ++ map declFun decls'
dataType = HsDataDecl srcloc [] stmtRec []
[HsRecDecl srcloc stmtRec recFields] []
mkRecField decl = ([HsIdent $ stmtRecName decl], HsBangedTy (HsTyCon $ UnQual $ HsIdent"Statement"))
recFields = map mkRecField decls
decls' = map updateDeclSql decls
updateDeclSql decl = decl { declSQL = substituteVarsSql (declVars decl) (declSQL decl) }
hsapp fun = HsApp (HsVar $ UnQual $ HsSymbol fun)
hsapps fun exps = foldl HsApp (HsVar $ UnQual $ HsSymbol fun) exps
hsvar v = HsVar $ UnQual $ HsSymbol v
stmtRecName decl = "stmt_" ++ declName decl
initFun decls =
hsSimpleFun "init" ["conn"] body []
where body = HsUnGuardedRhs $ HsDo (mkStmts ++ [returnRec])
mkStmts = map mkStmt decls
mkStmt decl = HsGenerator srcloc (HsPVar $ HsIdent $ declName decl)
(hsapps "prepare" [hsvar "conn", HsLit $ HsString sqlText])
where sqlText = printSql [declSQL decl]
returnRec = HsQualifier $ hsapp "return" $ HsRecConstr (UnQual $ stmtRec) fields
fields = map mkField decls
mkField decl = HsFieldUpdate
(UnQual $ HsIdent $ stmtRecName decl)
(HsVar $ UnQual $ HsIdent $ declName decl)
declFun decl = -- TODO declLOC
hsSimpleFun (declName decl) ("h":declVars decl) body (stmtDef : maybeTupleFun)
where body = HsUnGuardedRhs $ HsDo (bindAndExecute:result)
bindAndExecute = HsQualifier $ hsapps "execute" [stmt, valList]
selectFlag = isSelect $ declSQL decl
result
| selectFlag = [resultStmt decl stmt]
| otherwise = []
maybeTupleFun
| selectFlag = [tupleFun $ selectColumnLength $ declSQL decl]
| otherwise = []
stmt = HsVar $ UnQual $ HsSymbol "stmt"
valList = HsList $ map mkSqlVal $ declVars decl
mkSqlVal v = hsapp "toSql" (hsvar v)
stmtDef = HsPatBind srcloc (HsPVar $ HsIdent "stmt")
(HsUnGuardedRhs $ HsApp (HsVar $ UnQual $ HsIdent $ stmtRecName decl) (hsvar "h"))
[]
resultStmt decl stmt = HsQualifier $ hsapps "fmap" [HsParen (hsapp "fmap" (hsvar "toTuple")), HsParen (hsapp (prefix++suffix) stmt)]
where suffix
| otherwise = ""
prefix
| declMaybe decl = "fetchRow"
| otherwise = "fetchAllRows'"
tupleFun n = HsFunBind [
HsMatch srcloc (HsIdent "toTuple") [HsPList $ map HsPVar lvars]
(HsUnGuardedRhs (HsTuple (map convVar lvars))) []
, HsMatch srcloc (HsIdent "toTuple") [HsPWildCard]
(HsUnGuardedRhs (hsapp "error" $ HsLit $ HsString "hesql internal error"))
[]
]
where lvars = map lvar [1..n]
lvar i = HsIdent $ "v" ++ show i
convVar v = hsapp "fromSql" (HsVar (UnQual v))
{-
placeHolderCols AllColumns = []
placeHolderCols (ExplicitColumns cols) =
concatMap placeHoldersExp $ map fst cols
placeHoldersSql (SELECT _ cols from wh ord grp) =
placeHolderCols cols ++ maybe [] placeHoldersExp wh
placeHoldersSql (INSERT _ _ vals) =
concatMap placeHoldersExp vals
placeHoldersSql (UPDATE _ updates wh) =
concatMap (placeHoldersExp . snd) updates ++
maybe [] placeHoldersExp wh
placeHoldersExp (SqlPlaceHolder ph) = [ph]
placeHoldersExp (SqlInfixApp e1 _ e2) = placeHoldersExp e1 ++ placeHoldersExp e2
placeHoldersExp (SqlColumn _) = []
placeHoldersExp (SqlFunApp n args) = concatMap placeHoldersExp args
placeHoldersExp (SqlLiteral _) = []
placeHoldersExp (SqlNot e) = placeHoldersExp e
substituteVarsExp vars (SqlInfixApp e1 op e2) =
SqlInfixApp e1' op e2'
where e1' = substituteVarsExp vars e1
e2' = substituteVarsExp vars e2
substituteVarsExp _ sql@(SqlPlaceHolder _) = sql
substituteVarsExp _ sql@(SqlLiteral _) = sql
substituteVarsExp vars sql@(SqlColumn col)
| col `elem` vars = SqlPlaceHolder col
| otherwise = sql
substituteVarsExp vars (SqlNot e) = SqlNot (substituteVarsExp vars e)
substituteVarsExp vars (SqlFunApp n args) =
SqlFunApp n (map (substituteVarsExp vars) args)
substituteVarsSql vars (SELECT opt cols from wh ord grp) =
SELECT opt cols from
wh'
ord grp
where wh' :: Maybe SqlExp
wh' = fmap (substituteVarsExp vars) wh
substituteVarsSql vars (INSERT tab spec vals) =
INSERT tab spec $ map (substituteVarsExp vars) vals
substituteVarsSql vars (UPDATE tab updates wh) =
UPDATE tab updates' $ fmap (substituteVarsExp vars) wh
where updates' = map (mapSnd $ substituteVarsExp vars) updates
mapSnd f (a, b) = (a, f b)
selectColumnLength (ExplicitColumns cols) = length cols
-}
substituteVarsSql :: [String] -> Statement -> Statement
substituteVarsSql vars sql =
case sql of
SelectStatement ann se -> SelectStatement ann $ substituteSelectExpression vars se
Update ann table sets wh sl ->
Update ann table
(substituteSetClauselList vars sets)
(fmap (substituteExpression vars) wh )
(fmap (substituteSelectList vars) sl)
Insert ann tab cols e sl ->
Insert ann tab cols (substituteSelectExpression vars e)
sl
_ -> todo "substituteVarsSql"
substituteSetClauselList vars = map (substituteSetClausel vars)
substituteSetClausel vars (SetClause ann a e) = SetClause ann a (substituteExpression vars e)
substituteSetClausel vars (RowSetClause ann as es) = RowSetClause ann as $ map (substituteExpression vars) es
substituteSelectExpression vars sql =
case sql of
Select ann dist sl tabref wh groupby having order dir a b ->
-- TODO names for a? and b?
Select ann dist
(substituteSelectList vars sl)
tabref -- TODO
(se' wh)
(map se groupby)
(se' having)
(map se order)
dir
(se' a)
(se' b)
Values ann el ->
Values ann (map (map (substituteExpression vars)) el)
where se = substituteExpression vars
se' = fmap se
substituteExpression :: [String] -> Expression -> Expression
substituteExpression _ l@(BooleanLit _ _) = l
substituteExpression _ l@(FloatLit _ _) = l
substituteExpression vars l@(FunCall ann s el) =
FunCall ann s (fmap (substituteExpression vars) el)
substituteExpression _ l@(StringLit _ _ _) = l
substituteExpression _ l@(IntegerLit _ _) = l
substituteExpression vars id@(Identifier ann v) =
case v `elemIndex` vars of
Nothing -> id
Just i -> PositionalArg ann (fromIntegral i+1)
substituteExpression _ l = error $ "substituteExpression: " ++ show l
substituteSelectList vars (SelectList ann sis sl) = SelectList ann sis' sl
where sis' = map (substituteSelectItem vars) sis
substituteSelectItem vars item =
case item of
SelExp ann e -> SelExp ann (substituteExpression vars e)
SelectItem ann e s -> SelectItem ann (substituteExpression vars e) s
--substituteExpression _ _ = todo "substituteExpression" -- TODO print Exp