Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

Generate calls to rawSql

View GenRawSql.hs
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 ∷ StringQ 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
Something went wrong with that request. Please try again.