module Data.Ruin.QQ (
expQQ,
expQQA,
pars,
patQQ,
rna,
rnaA,
rpat,
) where
import Data.Maybe (catMaybes)
import GHC.Prim (Proxy#,proxy#)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Text.Parsec (parse)
import Data.Ruin.All
import Data.Ruin.Hoid
import Data.Ruin.Internal
import Data.Ruin.QQ.Parser
pars :: (QQ -> TH.Q a) -> String -> TH.Q a
pars k s = either (fail . show) k $ parse pQQ "rna quasiquote" s
expQQ :: QQ -> TH.ExpQ
expQQ (MkQQ typename binders) = case typename of
Nothing -> e
Just s -> [e| prto (proxy# :: Proxy# $(TH.conT (TH.mkName s))) $e |]
where
e = foldr TH.appE val (catMaybes seqs)
(seqs,vals) = unzip $ map mk binders
val = tupE vals
mk (strictness,var,field) =
( if strictness then Just [e| seq $v |] else Nothing
, [e| dub (mkLabel :: Label $(TH.litT (TH.strTyLit field))) $v |]
)
where
v = TH.varE (TH.mkName var)
expQQA :: QQ -> TH.ExpQ
expQQA (MkQQ typename binders) =
foldl app [e| pure $fun |] binders
where
app f (_,var,_) = [e| $f <*> $(TH.varE (TH.mkName var)) |]
fun = do
(seqs,pats,vals) <- unzip3 <$> mapM mk binders
let e = tupE vals
let result = case typename of
Nothing -> e
Just s -> [e| prto (proxy# :: Proxy# $(TH.conT (TH.mkName s))) $e |]
TH.lamE pats $ foldr TH.appE result (catMaybes seqs)
mk (strictness,var,field) = do
n <- TH.newName (if "_" == var then "x" else var)
let v = TH.varE n
return (
if strictness then Just [e| seq $v |] else Nothing
,
TH.varP n
,
[e| dub (mkLabel :: Label $(TH.litT (TH.strTyLit field))) $v |]
)
patQQ :: QQ -> TH.PatQ
patQQ (MkQQ typename binders) = case typename of
Nothing -> tp
Just s -> [p| (rup . phoid (proxy# :: Proxy# $(TH.conT (TH.mkName s))) -> $tp) |]
where
tp = tupP $ map mk binders
mk (strictness,var,field) = bang p
where
bang = if strictness then TH.bangP else id
p = [p| (undub (mkLabel :: Label $(TH.litT (TH.strTyLit field))) -> $v) |]
v = if "_" == var then TH.wildP else TH.varP (TH.mkName var)
tupE :: [TH.ExpQ] -> TH.ExpQ
tupE [e] = [e| MkTup1 $e |]
tupE es = TH.tupE es
tupP :: [TH.PatQ] -> TH.PatQ
tupP [p] = [p| MkTup1 $p |]
tupP ps = TH.tupP ps
rna :: QuasiQuoter
rna = QuasiQuoter (pars expQQ) (pars patQQ) nope nope
where
nope = fail "The `rna' quasiquoter only creates expressions or patterns."
rnaA :: QuasiQuoter
rnaA = QuasiQuoter (pars expQQA) nope nope nope
where
nope = fail "The `rnaA' quasiquoter only creates expressions."
rpat :: QuasiQuoter
rpat = QuasiQuoter nope (pars patQQ) nope nope
where
nope = fail "The `rpat' quasiquoter only creates patterns."