lmonad-yesod-0.1.0.0: src/Database/LEsqueleto.hs
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module Database.LEsqueleto (mkLSql, module Export) where
import Control.Monad.Trans.Class (lift)
import Data.Attoparsec.Text (parseOnly)
import qualified Data.Char as Char
import qualified Data.List as List
import Data.Maybe (fromJust)
import qualified Database.Esqueleto as Esq
import Database.Esqueleto as Export (Value(..), SqlBackend)
import Data.Maybe (isJust)
import Database.Persist.Types
import Data.Text (Text)
import qualified Data.Text as Text
import Database.LPersist
--import Database.Persist
import qualified Language.Haskell.Meta.Parse as Meta
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import LMonad.TCB
import Database.LEsqueleto.LSql
import Internal
-- | Generate the quasiquoter function `lsql` that parses the esqueleto DSL.
mkLSql :: [EntityDef] -> Q [Dec]
mkLSql ents' =
let lsql = mkName "lsql" in
let sig = SigD lsql (ConT ''QuasiQuoter) in
let ents = mkSerializedLEntityDefs $ map toLEntityDef ents' in
let def = ValD (VarP lsql) (NormalB (AppE (VarE 'lsqlHelper) ents)) [] in
let lsql' = mkName "lsql'" in
let sig' = SigD lsql' (ConT ''QuasiQuoter) in
let def' = ValD (VarP lsql') (NormalB (AppE (VarE 'lsqlHelper') ents)) [] in
return [ sig, def, sig', def']
-- | Serialize LEntityDefs so that lsql can access them in other modules.
-- Ex:
--
-- [ LEntityDef "User" [LFieldDef "ident" (FTTypeCon "Text") True Nothing, ...], ...]
mkSerializedLEntityDefs :: [LEntityDef] -> Exp
mkSerializedLEntityDefs ents' =
ListE $ List.map mkSerializedLEntityDef ents'
where
mkSerializedLEntityDef ent =
let str = LitE $ StringL $ lEntityHaskell ent in
let fields = mkSerializedLFieldsDef $ lEntityFields ent in
-- if (lEntityHaskell ent) == "User" then
-- error $ show ent
-- else
AppE (AppE (ConE 'LEntityDef) str) fields
mkSerializedText t = SigE (LitE $ StringL $ Text.unpack t) (ConT ''Text)
mkSerializedFieldType typ = case typ of
FTTypeCon moduleM' name' ->
let moduleM = maybe (ConE 'Nothing) (\m -> AppE (ConE 'Just) (mkSerializedText m)) moduleM' in
let name = mkSerializedText name' in
AppE (AppE (ConE 'FTTypeCon) moduleM) name
FTApp typ1' typ2' ->
let typ1 = mkSerializedFieldType typ1' in
let typ2 = mkSerializedFieldType typ2' in
AppE (AppE (ConE 'FTApp) typ1) typ2
FTList typ' ->
let typ = mkSerializedFieldType typ' in
AppE (ConE 'FTList) typ
mkSerializedLabelAnnotation la = case la of
LAId ->
ConE 'LAId
LAConst s ->
AppE (ConE 'LAConst) (LitE $ StringL s)
LAField s ->
AppE (ConE 'LAField) (LitE $ StringL s)
mkSerializedLFieldsDef fields' =
let helper field =
let name = LitE $ StringL $ lFieldHaskell field in
let typ = mkSerializedFieldType $ lFieldType field in
let strict = ConE $ if lFieldStrict field then 'True else 'False in
let anns = maybe (ConE 'Nothing) (\( r', w', c') ->
let r = ListE $ map mkSerializedLabelAnnotation r' in
let w = ListE $ map mkSerializedLabelAnnotation w' in
let c = ListE $ map mkSerializedLabelAnnotation c' in
AppE (ConE 'Just) $ TupE [ r, w, c]
) $ lFieldLabelAnnotations field
in
AppE (AppE (AppE (AppE (ConE 'LFieldDef) name) typ) strict) anns
in
ListE $ map helper fields'
lsqlHelper :: [LEntityDef] -> QuasiQuoter
lsqlHelper ents = QuasiQuoter {
quoteExp = (generateSql ents) . Text.pack
}
generateSql :: [LEntityDef] -> Text -> Q Exp
generateSql lEntityDefs s =
-- Parse the DSL.
let ast = case parseOnly parseCommand s of
Left err ->
error $ "Error parsing lsql statement: " ++ err
Right res ->
res
in
let normalized = normalizeTerms ast in
let isTableOptional tableS =
let createAssoc (Tables ts join table _) lvl' =
let ( lvl, next, prev) = case join of
LeftOuterJoin ->
if lvl' == 0 then
( 1, 0, 1)
else
( lvl', lvl' - 1, 0)
InnerJoin ->
( lvl', lvl', 0)
RightOuterJoin ->
( lvl', lvl' + 1, 0)
FullOuterJoin ->
( lvl' + 1, lvl' + 1, 1)
in
let ( mapping, correction) = createAssoc ts next in
( ( table, lvl + correction):mapping, prev + correction)
createAssoc (Table table) lvl =
( [( table, lvl)], 0)
in
let ( mapping, _) = createAssoc (commandTables normalized) (0 :: Int) in
-- error $ show mapping
maybe
(error $ "Could not find table `" ++ tableS ++ "`")
(> 0)
$ List.lookup tableS mapping
in
let protected = (commandSelect normalized) == PSelect in
let terms = reqTermsCommand isTableOptional normalized in
-- TODO: Add some check that all the table and field names used match up with existing things?? XXX
{-
...
normalize terms
make map from tables -> isMaybe??
get all terms
get all dependency terms (or a map of terms -> [dependencies]??)
union terms and dependency terms
generate sql query
generate map over results
taintlabel or tolabeled result
return terms
...
need to check if fields/tables are maybes???
-}
do
-- error $ show ast
res <- newName "res"
let query =
let tables = commandTables normalized in
let returns = AppE (VarE 'return) $ TupE $ List.map (\rterm -> case rterm of
ReqField table field _ _ ->
mkExprTF (isTableOptional table) table field -- TODO: Does the option matter here??? XXX
-- mkExprTF False table field -- TODO: Does the option matter here??? XXX
ReqEntity ent _ _ ->
VarE $ varNameTable ent
) terms
in
BindS (VarP res) $ AppE (VarE 'Esq.select) $ AppE (VarE 'Esq.from) $
LamE [mkQueryPatternTables tables] $ DoE
((mkOnTables isTableOptional tables)
++ (mkWhere isTableOptional $ commandWhere normalized)
++ (mkOrderBy isTableOptional $ commandOrderBy normalized)
++ (mkLimit $ commandLimit normalized)
++ (mkOffset $ commandOffset normalized)
++ [NoBindS returns])
let taint =
let fun =
let pat = TupP $ List.map ( \rterm ->
let constr = case rterm of
ReqField table field _ _ ->
ConP 'Value [VarP $ varNameTableField table field]
ReqEntity table optional _ ->
if optional then
VarP $ varNameTableField table "maybe"
else
mkEntityPattern table
in
constr
) terms
in
let body =
let getExpr table field =
let res = List.foldl' ( \acc rterm -> maybe ( case rterm of
ReqField table' field' _ _
| table == table' && field == field' ->
Just $ VarE $ varNameTableField table field
ReqEntity table' optional _
| table == table' ->
-- TODO: implement this FIXME XXX
let expr =
if field == "id" then
VarE $ varNameTableField table field
else
let getter = mkName $ (headToLower table) ++ (headToUpper field) in
AppE (VarE getter) $ VarE $ varNameTable table
in
Just $ if optional then
-- Here we assert that the field is not Nothing, since we know that is optional. Warning: If this assertion is wrong, things could fail at runtime.
let body = AppE (VarE 'fromJust) (VarE $ varNameTableField table' "maybe") in
LetE [ValD (mkEntityPattern table') (NormalB body) []] expr
else
expr
_ ->
acc
) Just acc ) Nothing terms
in
maybe (error $ "Could not find expression for table `"++table++"` and field `"++field++"`") id res
in
let taints = List.foldr (\rterm acc -> case rterm of
ReqField _ _ False _ ->
acc
ReqField _ _ _ Nothing ->
acc
ReqField table field _returning (Just deps) ->
let labeler = VarE $ mkName $ "readLabel" ++ (headToUpper table) ++ (headToUpper field) ++ "'" in
let label = List.foldl' (\acc (table',field') ->
AppE acc $ getExpr table' field'
) labeler deps
in
let stmt = if protected then
let vName = varNameTableFieldP table field in
let lName = mkName "_protected_label" in
let lDec = ValD (VarP lName) (NormalB label) [] in
BindS (VarP vName) $ LetE [lDec] $ AppE (AppE (VarE 'toLabeledTCB) (VarE lName)) $ DoE [
NoBindS $ AppE (VarE 'taintLabel) (VarE lName),
NoBindS $ AppE (VarE 'return) (VarE $ varNameTableField table field)
]
else
NoBindS $ AppE (VarE 'taintLabel) label
in
stmt:acc
ReqEntity _table _ False ->
acc
ReqEntity table optional True ->
let optionCase base handler = AppE (AppE (AppE (VarE 'maybe) (AppE (VarE 'return) base)) handler) (VarE $ varNameTableField table "maybe") in
let nonoptionCase handler = AppE handler $ VarE $ varNameTableE table in
let stmt = if protected then
let vName = varNameTableP table in
BindS (VarP vName) $ if optional then
let tName = mkName "_tmp" in
optionCase (ConE 'Nothing) $ LamE [VarP tName] $ parenInfixE (AppE (VarE 'toProtected) (VarE tName)) (VarE '(>>=)) $ parenInfixE (VarE 'return) (VarE '(.)) (ConE 'Just)
else
nonoptionCase $ VarE 'toProtected
else
NoBindS $ if optional then
optionCase (ConE '()) $ VarE 'raiseLabelRead
else
nonoptionCase $ VarE 'raiseLabelRead
in
stmt:acc
) [] terms
in
let returns = NoBindS $ AppE (VarE 'return) $ TupE $ List.foldr (\rterm acc -> case rterm of
ReqField table field ret _ ->
if ret then
let vName = (if protected then varNameTableFieldP else varNameTableField) table field in
(VarE vName):acc
else
acc
ReqEntity table optional _ ->
let name = if protected then
varNameTableP table
else
if optional then
varNameTableField table "maybe"
else
varNameTableE table
in
(VarE name):acc
) [] terms
in
DoE $ taints ++ [returns]
in
LamE [pat] body
in
NoBindS $ AppE (VarE 'lift)$ AppE (AppE (VarE 'mapM) fun) (VarE res)
-- error $ pprint $ DoE [ query, taint]
return $ DoE [ query, taint]
where
mkEntityPattern table =
AsP (varNameTableE table) $ ConP 'Entity [ VarP $ varNameTableField table "id", VarP $ varNameTable table]
mkQueryPatternTables (Table table) = VarP $ varNameTable table
mkQueryPatternTables (Tables ts j table _) =
let constr = case j of
InnerJoin -> 'Esq.InnerJoin
LeftOuterJoin -> 'Esq.LeftOuterJoin
RightOuterJoin -> 'Esq.RightOuterJoin
FullOuterJoin -> 'Esq.FullOuterJoin
-- CrossJoin -> 'CrossJoin
in
ConP constr [ mkQueryPatternTables ts, VarP $ varNameTable table]
mkWhere _ Nothing = []
mkWhere isTableOptional (Just (Where expr)) = [NoBindS $ AppE (VarE 'Esq.where_) $ mkExprBExpr isTableOptional expr]
-- hasLabelsHelper tableS f = List.foldl' (\acc ent ->
-- if acc || (lEntityHaskell ent) /= tableS then
-- acc
-- else
-- List.foldl' (\acc field ->
-- if acc || f field then
-- acc
-- else
-- maybe False (\_ -> True) $ lFieldLabelAnnotations field
-- ) False $ lEntityFields ent
-- ) False lEntityDefs
-- hasLabelsTable tableS = hasLabelsHelper tableS (\_ -> False)
-- hasLabelsTableField tableS fieldS = hasLabelsHelper tableS $ \f -> (lFieldHaskell f) /= fieldS
mkOrderBy _ Nothing = []
mkOrderBy isTableOptional (Just (OrderBy ords')) =
let helper ord =
let ( op,( table, field)) = case ord of
OrderAsc t -> ( 'Esq.asc, extractTableField t)
OrderDesc t -> ( 'Esq.desc, extractTableField t)
in
AppE (VarE op) $ mkExprTF (isTableOptional table) table field
-- AppE (VarE op) $ mkExprTF False table field
in
let ords = List.map helper ords' in
[NoBindS $ AppE (VarE 'Esq.orderBy) $ ListE ords]
mkLimit Nothing = []
mkLimit (Just (Limit limit)) = [NoBindS $ AppE (VarE 'Esq.limit) $ LitE $ IntegerL limit]
mkOffset Nothing = []
mkOffset (Just (Offset offset)) = [NoBindS $ AppE (VarE 'Esq.offset) $ LitE $ IntegerL offset]
mkOnTables _ (Table _table) = []
mkOnTables isTableOptional (Tables ts _ _ bexpr@(BExprBinOp (BTerm _term1) BinEq (BTerm _term2))) =
(NoBindS $ AppE (VarE 'Esq.on) $ mkExprBExpr isTableOptional bexpr):(mkOnTables isTableOptional ts)
mkOnTables _ (Tables _ _ table _) = error $ "mkOnTables: Invalid on expression for table `" ++ table ++ "`"
mkExprBExpr isTableOptional (BExprBinOp (BTerm term1) op' (BTerm term2)) =
let (table1,field1) = extractTableField term1 in
let (table2,field2) = extractTableField term2 in
let tableOptional1 = isTableOptional table1 in -- TODO: This is probably incorrect?? Need to consider the relationship between the two tables? XXX
let tableOptional2 = isTableOptional table2 in
let expr1' = mkExprTF tableOptional1 table1 field1 in
let expr2' = mkExprTF tableOptional2 table2 field2 in
let fieldOptional1 = isTableFieldOptional table1 field1 in
let fieldOptional2 = isTableFieldOptional table2 field2 in
let optional1 = tableOptional1 || fieldOptional1 in
let optional2 = tableOptional2 || fieldOptional2 in
let ( expr1, expr2) = case ( optional1, optional2) of
( True, False) ->
( expr1', AppE (VarE 'Esq.just) expr2')
( False, True) ->
( AppE (VarE 'Esq.just) expr1', expr2')
_ ->
( expr1', expr2')
in
let op = mkExprBOp op' in
--error $ (show tableOptional1) ++":"++ (show tableOptional2) ++":"++ (show optional1) ++":"++ (show optional2)
parenInfixE expr1 op expr2
mkExprBExpr isTableOptional (BExprBinOp b1 op b2) = parenInfixE
(mkExprB isTableOptional b1) (mkExprBOp op) (mkExprB isTableOptional b2)
mkExprBExpr isTableOptional (BExprAnd e1 e2) = parenInfixE
(mkExprBExpr isTableOptional e1) (VarE '(Esq.&&.)) (mkExprBExpr isTableOptional e2)
mkExprBExpr isTableOptional (BExprOr e1 e2) = parenInfixE
(mkExprBExpr isTableOptional e1) (VarE '(Esq.||.)) (mkExprBExpr isTableOptional e2)
mkExprBExpr isTableOptional (BExprNull t) = AppE (VarE 'Esq.isNothing) $ mkExprTerm isTableOptional t
mkExprBExpr isTableOptional (BExprNotNull t) = AppE (VarE 'Esq.not_) $ AppE (VarE 'Esq.isNothing) $ mkExprTerm isTableOptional t
mkExprBExpr isTableOptional (BExprNot expr) = AppE (VarE 'Esq.not_) $ mkExprBExpr isTableOptional expr
mkExprBOp BinEq = VarE '(Esq.==.)
mkExprBOp BinNEq = VarE '(Esq.!=.)
mkExprBOp BinGE = VarE '(Esq.>=.)
mkExprBOp BinG = VarE '(Esq.>.)
mkExprBOp BinLE = VarE '(Esq.<=.)
mkExprBOp BinL = VarE '(Esq.<.)
mkExprB isTableOptional (BTerm t) = mkExprTerm isTableOptional t
mkExprB _ (BAnti s) = case Meta.parseExp s of
Left e -> error e
Right e -> AppE (VarE 'Esq.val) $ e
mkExprB _ (BConst c) = mkExprConst c
mkExprConst (CBool True) = AppE (VarE 'Esq.val) $ ConE 'True
mkExprConst (CBool False) = AppE (VarE 'Esq.val) $ ConE 'False
mkExprConst (CString s) = AppE (VarE 'Esq.val) $ LitE $ StringL s
mkExprConst (CInt i) = AppE (VarE 'Esq.val) $ LitE $ IntegerL i
mkExprConst (CDouble d) = AppE (VarE 'Esq.val) $ LitE $ DoublePrimL $ toRational d
mkExprTF tableOptional table field =
let op = VarE $ if tableOptional then '(Esq.?.) else '(Esq.^.) in
let fieldName = constrNameTableField table field in
let var = varNameTable table in
parenInfixE (VarE var) op (ConE fieldName)
mkExprTerm isTableOptional term =
let (tableS, fieldS) = extractTableField term in
mkExprTF (isTableOptional tableS) tableS fieldS
getLTable tableS =
let findEntity [] = error $ "Could not find table `" ++ tableS ++ "`"
findEntity (h:t) =
if toLowerString (lEntityHaskell h) == toLowerString tableS then
h
else
findEntity t
in
findEntity lEntityDefs
getLTableField tableS fieldS =
if fieldS == "id" then
let typ = FTTypeCon Nothing (Text.pack $ tableS ++ "Id") in
LFieldDef fieldS typ True Nothing
else
let ent = getLTable tableS in
let findField [] = error $ "Could not find field `" ++ fieldS ++ "` for table `" ++ tableS ++ "`"
findField (h:t) =
if toLowerString (lFieldHaskell h) == toLowerString fieldS then
h
else
findField t
in
findField $ lEntityFields ent
isTableFieldOptional tableS fieldS =
case lFieldType $ getLTableField tableS fieldS of
FTApp (FTTypeCon _ "Maybe") _ ->
True
_ ->
False
extractTableField (TermTF t (Field f)) = ( t, f)
extractTableField (TermTF t FieldAll) = error $ "extractTableField: All fields requested for table `" ++ t ++ "`"
extractTableField (TermF f) = error $ "extractTableField: Invalid terminal field `TermF " ++ (show f) ++ "`"
toLowerString = List.map Char.toLower
varNameTable table = mkName $ '_':(toLowerString table)
varNameTableE table = mkName $ '_':'e':'_':(toLowerString table)
varNameTableP table = mkName $ '_':'p':'_':(toLowerString table)
varNameTableField table field = mkName $ '_':((toLowerString table) ++ ('_':(toLowerString field)))
varNameTableFieldP table field = mkName $ '_':'p':'_':((toLowerString table) ++ ('_':(toLowerString field)))
constrNameTableField table field = mkName $ (headToUpper table) ++ (headToUpper field)
reqTermsCommand isTableOptional (Command _ terms tables whereM orderByM _limitM _offsetM) =
-- Get all requested terms
-- transform to ReqTerm
-- get the dependencies of all the other terms
-- union (and transform) into rest of dependency terms, requested false
let terms' = case terms of
Terms terms -> terms
TermsAll -> error "reqTermsCommand: normalization failed"
in
let reqTerms = List.map (reqTermsTerm isTableOptional True) terms' in
let reqTerms' = reqTermsTables isTableOptional reqTerms tables in
let reqTerms'' = maybe reqTerms' (reqTermsWhere isTableOptional reqTerms') whereM in
maybe reqTerms'' (reqTermsOrderBy isTableOptional reqTerms'') orderByM
--let reqTerms''' = maybe reqTerms'' (reqTermsOrderBy reqTerms'') orderByM in
--let reqTerms'''' = maybe reqTerms''' (reqTermsLimit reqTerms''') limitM in
--maybe reqTerms'''' (reqTermsOffset reqTerms'''') offsetM
reqTermsOrderBy isTableOptional curTerms (OrderBy ords) = List.foldl' (\acc ord -> case ord of
OrderAsc t ->
reqTermsTermMaybe isTableOptional acc t
OrderDesc t ->
reqTermsTermMaybe isTableOptional acc t
) curTerms ords
reqTermsWhere isTableOptional curTerms (Where bexpr) = reqTermsBExpr isTableOptional curTerms bexpr
reqTermsTables :: (String -> Bool) -> [ReqTerm] -> Tables -> [ReqTerm]
reqTermsTables isTableOptional curTerms (Tables ts _ _ bexpr) =
reqTermsTables isTableOptional (reqTermsBExpr isTableOptional curTerms bexpr) ts
reqTermsTables _ curTerms (Table _) = curTerms
reqTermsBExpr :: (String -> Bool) -> [ReqTerm] -> BExpr -> [ReqTerm]
reqTermsBExpr isTableOptional curTerms (BExprAnd e1 e2) = reqTermsBExpr isTableOptional (reqTermsBExpr isTableOptional curTerms e1) e2
reqTermsBExpr isTableOptional curTerms (BExprOr e1 e2) = reqTermsBExpr isTableOptional (reqTermsBExpr isTableOptional curTerms e1) e2
reqTermsBExpr isTableOptional curTerms (BExprBinOp b1 _ b2) = reqTermsB isTableOptional (reqTermsB isTableOptional curTerms b1) b2
reqTermsBExpr isTableOptional curTerms (BExprNull t) = reqTermsTermMaybe isTableOptional curTerms t
reqTermsBExpr isTableOptional curTerms (BExprNotNull t) = reqTermsTermMaybe isTableOptional curTerms t
reqTermsBExpr isTableOptional curTerms (BExprNot e) = reqTermsBExpr isTableOptional curTerms e
reqTermsB :: (String -> Bool) -> [ReqTerm] -> B -> [ReqTerm]
reqTermsB isTableOptional curTerms (BTerm t) = reqTermsTermMaybe isTableOptional curTerms t
reqTermsB _ curTerms _ = curTerms
-- Union in new term. Term should never be an entity.
reqTermsTermMaybe :: (String -> Bool) -> [ReqTerm] -> Term -> [ReqTerm]
reqTermsTermMaybe isTableOptional curTerms term =
let ( tableS, fieldS) = extractTableField term in
let reqTerm = reqTermsTerm isTableOptional False term in
let cons = List.foldl' (\acc term -> case term of
ReqEntity tableS' _ _ ->
if tableS == tableS' then
False
else
acc
ReqField tableS' fieldS' _returning _ ->
if tableS == tableS' && fieldS == fieldS' then
False
else
acc
) True curTerms
in
if cons then
reqTerm:curTerms
else
curTerms
reqTermsTerm isTableOptional returning (TermTF tableS field) = case field of
Field fieldS ->
let fieldDef = getLTableField tableS fieldS in
let dep = maybe Nothing (\( anns, _, _) -> Just $ List.foldl' (\acc ann -> case ann of
LAId ->
( tableS, "id"):acc
LAConst _s ->
acc
LAField f ->
( tableS, f):acc
) [] anns ) $ lFieldLabelAnnotations fieldDef in
ReqField tableS fieldS returning dep
FieldAll ->
let hasDeps =
let ent = getLTable tableS in
List.foldl' (\acc f -> acc || isJust (lFieldLabelAnnotations f)) False $ lEntityFields ent
in
let optional = isTableOptional tableS in
-- if (lEntityHaskell $ getLTable tableS) == "User" then
-- error $ show $ getLTable tableS
-- else
ReqEntity tableS optional hasDeps
reqTermsTerm _ _ (TermF _) = error "reqTermsTerm: normalization failed"
-- selectE = VarE $ mkName "select"
-- fromE = VarE $ mkName "from"
-- where_E = VarE $ mkName "where_"
-- onE = VarE $ mkName "on"
-- justE = VarE $ mkName "just"
-- carotE = VarE $ mkName "^."
-- questionE = VarE $ mkName "?."
-- eqE = VarE $ mkName "==."
-- geE = VarE $ mkName ">=."
-- gE = VarE $ mkName ">."
-- leE = VarE $ mkName "<=."
-- lE = VarE $ mkName "<."
-- innerJoin = VarE $ mkName "InnerJoin"
-- leftOuterJoin = VarE $ mkName "LeftOuterJoin"
-- rightOuterJoin = VarE $ mkName "RightOuterJoin"
-- fullOuterJoin = VarE $ mkName "FullOuterJoin"
-- crossJoin = VarE $ mkName "CrossJoin"
data ReqTerm =
ReqField {
_reqFieldTable :: String
, _reqFieldField :: String
-- , _reqFieldIsOptional :: Bool
, _reqFieldReturning :: Bool
, _reqFieldDependencies :: Maybe [(String,String)] -- Contains ( table, field) dependencies.
-- , _reqFieldIsDependency :: Bool
}
| ReqEntity {
_reqEntityTable :: String -- Implied returning is true
, _reqEntityIsOptional :: Bool
, _reqEntityHasLabels :: Bool
}
deriving (Show)
-- | Normalize an AST by adding table name for all terms. Also expands out all the tables requested when TermsAll is applied.
normalizeTerms :: Command -> Command
normalizeTerms (Command select terms tables whereM orderByM limitM offsetM) =
-- Get the default table if there are no joins.
let defTable = case tables of
Table table ->
Just table
_ ->
Nothing
in
let terms' = case terms of
TermsAll ->
-- Expand all the tables out.
let expander acc tables = case tables of
Table table ->
(TermTF table FieldAll):acc
Tables tables _ table _ ->
expander ((TermTF table FieldAll):acc) tables
in
Terms $ expander [] tables
Terms terms' ->
-- Add table name to each term.
Terms $ List.map (updateTerm defTable) terms'
in
-- This checks that terms should already have tables included.
let tables' = updateTables defTable tables in
let whereM' = case whereM of
Just (Where bexpr) ->
Just $ Where $ updateBExpr defTable bexpr
Nothing ->
Nothing
in
let orderByM' = case orderByM of
Just (OrderBy orders) ->
let helper ord = case ord of
OrderAsc t ->
OrderAsc $ updateTerm defTable t
OrderDesc t ->
OrderDesc $ updateTerm defTable t
in
Just $ OrderBy $ List.map helper orders
Nothing ->
Nothing
in
Command select terms' tables' whereM' orderByM' limitM offsetM
where
updateTerm defTable term = case term of
TermF field ->
maybe
(error $ "Could not infer table associated with field `" ++ (show field) ++ "`")
(\table -> TermTF table field)
defTable
_ ->
term
updateTables defTable (Tables ts j table bexpr) =
Tables (updateTables defTable ts) j table $ updateBExpr defTable bexpr
updateTables _ t = t
updateBExpr defTable bexpr = case bexpr of
BExprAnd expr1 expr2 ->
BExprAnd (updateBExpr defTable expr1) (updateBExpr defTable expr2)
BExprOr expr1 expr2 ->
BExprOr (updateBExpr defTable expr1) (updateBExpr defTable expr2)
BExprBinOp b1 op b2 ->
BExprBinOp (updateB defTable b1) op (updateB defTable b2)
BExprNull t ->
BExprNull $ updateTerm defTable t
BExprNotNull t ->
BExprNotNull $ updateTerm defTable t
BExprNot expr ->
BExprNot $ updateBExpr defTable expr
updateB defTable (BTerm t) = BTerm $ updateTerm defTable t
updateB _ b = b
parenInfixE :: Exp -> Exp -> Exp -> Exp
parenInfixE e1 e2 e3 = ParensE $ UInfixE e1 e2 e3
-- Debugging functions.
lsqlHelper' :: [LEntityDef] -> QuasiQuoter
lsqlHelper' ents = QuasiQuoter {
quoteExp = (generateSql' ents) . Text.pack
}
where
generateSql' e s = do
res <- generateSql e s
error $ pprint res