hesql-0.7: HESQL/Translator.hs
module HESQL.Translator (generateCode) where
import Language.Haskell.Syntax
--import Database.HDBC.PostgreSQL
import HESQL.Syntax
--import HESQL.Verifier
import HESQL.Options
import System.FilePath
import Database.HsSqlPpp.PrettyPrinter.PrettyPrinter
import Database.HsSqlPpp.Ast.Ast
import Data.List (elemIndex)
stmtRec :: HsName
stmtRec = HsIdent "Stmts"
funarg :: String -> HsPat
funarg = HsPVar . HsIdent
funargs :: [String] -> [HsPat]
funargs = map funarg
srcloc :: SrcLoc
srcloc = SrcLoc "<dummy>" 1 1
hsSimpleFun :: String -> [String]
-> HsRhs -> [HsDecl]
-> HsDecl
hsSimpleFun name vars body wheres =
HsFunBind [HsMatch srcloc (HsIdent name) (funargs vars) body wheres]
generateCode :: FilePath -> Options -> HesqlModule -> IO HsModule
generateCode fn opts (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 opts) 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 :: HesqlDecls -> HesqlDecls
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 opts decl = -- TODO declLOC
hsSimpleFun (declName decl) params 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"))
[]
params | optDBLastArg opts = declVars decl++["h"]
| otherwise = "h":declVars decl
resultStmt decl stmt = HsQualifier $ hsapps "fmap" [HsParen (hsapp "fmap" (hsvar "toTuple")), HsParen (hsapp (fetchFun opt) stmt)]
where opt = declOpt decl
fetchFun MaybeQuery = "fetchRow"
fetchFun StrictQuery = "fetchAllRows'"
fetchFun LazyQuery = "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))
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 substE wh )
(substMSL sl)
Insert ann tab cols e sl ->
Insert ann tab cols (substituteSelectExpression vars e)
sl
Delete ann s wh msl ->
Delete ann s (fmap substE wh) (substMSL msl)
_ -> error $ "substituteVarsSql: " ++ show sql
where substE = substituteExpression vars
substMSL = fmap $ substituteSelectList vars
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 a b ->
-- TODO names for a? and b?
Select ann dist
(substituteSelectList vars sl)
tabref -- TODO
(se' wh)
(map se groupby)
(se' having)
(map sde order)
(se' a)
(se' b)
Values ann el ->
Values ann (map (map (substituteExpression vars)) el)
where se = substituteExpression vars
se' = fmap se
sde (e, dir) = (se e, dir)
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 vars (Case ann l e) =
Case ann l' e'
where e' = fmap substE e
l' = map substOneCase l
substE = substituteExpression vars
substOneCase (cs, e) = (map substE cs, substE e)
substituteExpression vars (CaseSimple ann e1 l e2) =
CaseSimple ann e1' l' e2'
where e1' = substE e1
e2' = fmap substE e2
l' = map substOneCase l
substE = substituteExpression vars
substOneCase (cs, e) = (map substE cs, substE e)
substituteExpression vars (Cast ann e tn) =
Cast ann (substituteExpression vars e) tn
substituteExpression vars (Exists ann e) =
Exists ann (substituteSelectExpression vars e)
substituteExpression vars l@(NullLit _) = l
substituteExpression vars (PositionalArg _ _)
= error "don't use PositionalArg"
substituteExpression vars (ScalarSubQuery ann se) =
ScalarSubQuery ann (substituteSelectExpression vars se)
substituteExpression vars (WindowFn ann e el1 el2 dir) =
WindowFn ann (substE e) (substEL el1) (substEL el2) dir
where substE = substituteExpression vars
substEL = map substE
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