public
Last active

Generate calls to rawSql

  • Download Gist
GenRawSql.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
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 exp return exp

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.