Create a gist now

Instantly share code, notes, and snippets.

Generate calls to rawSql
import Database.Persist.Store
import Database.Persist.EntityDef
import qualified Database.Persist.GenericSql as GenSql
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.Meta
import qualified Data.Text as T
-- example:
-- (fmap unSingle . listToMaybe → mcssid) ← runDB $
-- [genRawSql|select #{CssId} from @{Css} where !{UniqueCss name} and #{CssActive}=1|]
defQQ = QuasiQuoter undefined undefined undefined undefined
genRawSql QuasiQuoter
genRawSql = defQQ { quoteExp = \sql → let
(prepSql, argList) = prepareSql sql
prepareSql [] = ([],[])
prepareSql ('?':'{':rest) | (val, '}':rest') ← break (=='}') rest =
([Left '?'], [[| [toPersistValue $(varE $ mkName val)] |]])
`mappend` prepareSql rest'
prepareSql ('#':'{':rest) | (val, '}':rest') ← break (=='}') rest =
([Right [| (T.unpack . unDBName . fieldDB . persistFieldDef)
$(conE $ mkName val) |]], [])
`mappend` prepareSql rest'
prepareSql ('@':'{':rest) | (val, '}':rest') ← break (=='}') rest =
([Right [| (T.unpack . unDBName . entityDB . entityDef)
(halfDefined :: $(conT $ mkName val)) |]], [])
`mappend` prepareSql rest'
prepareSql ('!':'{':rest) | (val, '}':rest') ← break (=='}') rest =
([Right [| let u = $(anyE val) in (\x → "("++x++")") .
concat . intersperse " and " $
map (++" = ?") (map (T.unpack . unDBName . snd) $ persistUniqueToFieldNames u) |]],
[[| persistUniqueToValues $(anyE val) |]])
`mappend` prepareSql rest'
prepareSql (x:xs) = ([Left x],[]) `mappend` prepareSql xs
catPrepped acc (Left c : xs) = catPrepped (c:acc) xs
catPrepped acc (Right e : xs) =
stringE (reverse acc) : e : catPrepped "" xs
catPrepped acc [] = [stringE $ reverse acc]
in [|GenSql.rawSql
(T.pack $ concat $(listE . catPrepped "" $ prepSql))
(concat $(listE argList))|] }
anyE String Q Exp
anyE src = case parseExp src of
Left msg → fail msg
Right expreturn exp
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment