module Snap.Restful.TH
( deriveHasFormlet
, iSplices
, cSplices
) where
import Control.Applicative
import Language.Haskell.TH
import Snap.Restful
import Text.Digestive
nameCons :: Name -> Q [Con]
nameCons n = do
info <- reify n
case info of
TyConI dec -> decCons dec
_ -> return []
decCons :: Dec -> Q [Con]
decCons (DataD _ _ _ cons _) = return cons
decCons (NewtypeD _ _ _ con _) = return [con]
decCons (TySynD _ _ t) = typeCons t
decCons _ = return []
typeCons :: Type -> Q [Con]
typeCons (AppT a _) = typeCons a
typeCons (ConT n) = nameCons n
typeCons _ = return []
deriveHasFormlet :: Name -> Q [Dec]
deriveHasFormlet n = do
cons <- nameCons n
case cons of
[RecC conName fields] -> do
defName <- newName "d"
let fieldFormlet (fn,_,_) = do
let name = litE $ StringL $ nameBase fn
[| $name .: formlet ( $(varE fn) <$> $(varE defName) ) |]
(f:fs) <- mapM fieldFormlet fields
let start = UInfixE (ConE conName) (VarE '(<$>)) f
splat = VarE '(<*>)
res = foldl (\a b -> UInfixE a splat b) start fs
func = [FunD 'formlet [Clause [VarP defName] (NormalB res) []]]
return $ [InstanceD [] (AppT (ConT ''HasFormlet) (ConT n)) func]
_ -> error "You can only generate formlets for a data type with a single constructor and named record fields"
iSplices :: Name -> Q Exp
iSplices n = do
cons <- nameCons n
case cons of
[RecC conName fields] -> do
param <- newName "x"
let fieldToTuple (fn,_,_) = do
f <- [| iPrimSplice $ $(appE (varE fn) (varE param)) |]
return $ TupE [LitE $ StringL $ nameBase fn, f]
fs <- mapM fieldToTuple fields
return $ LamE [VarP param] (ListE fs)
_ -> error "You can only generate splices for a data type with a single constructor and named record fields"
cSplices :: Name -> Q Exp
cSplices n = do
cons <- nameCons n
case cons of
[RecC conName fields] -> do
let fieldToTuple (fn,_,_) = do
f <- [| cPrimSplice . $(varE fn) |]
return $ TupE [LitE $ StringL $ nameBase fn, f]
fs <- mapM fieldToTuple fields
return $ ListE fs
_ -> error "You can only generate splices for a data type with a single constructor and named record fields"