Generate calls to rawSql

GenRawSql.hs

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