module Text.Boomerang.TH (derivePrinterParsers) where
import Control.Monad (liftM, replicateM)
import Language.Haskell.TH
import Text.Boomerang.HStack ((:-)(..), arg)
import Text.Boomerang.Prim (xpure)
derivePrinterParsers :: Name -> Q [Dec]
derivePrinterParsers name = do
info <- reify name
case info of
TyConI (DataD _ _ _ cons _) ->
concat `liftM` mapM derivePrinterParser cons
TyConI (NewtypeD _ _ _ con _) ->
derivePrinterParser con
_ ->
fail $ show name ++ " is not a datatype."
derivePrinterParser :: Con -> Q [Dec]
derivePrinterParser con =
case con of
NormalC name tys -> go name (map snd tys)
RecC name tys -> go name (map (\(_,_,ty) -> ty) tys)
_ -> do
runIO $ putStrLn $ "Skipping unsupported constructor " ++ show (conName con)
return []
where
go name tys = do
let name' = mkPrinterParserName name
runIO $ putStrLn $ "Introducing router " ++ nameBase name' ++ "."
expr <- [| xpure $(deriveConstructor name (length tys))
$(deriveDestructor name tys) |]
return [FunD name' [Clause [] (NormalB expr) []]]
deriveConstructor :: Name -> Int -> Q Exp
deriveConstructor name arity = [| $(mk arity) $(conE name) |]
where
mk :: Int -> ExpQ
mk 0 = [| (:-) |]
mk n = [| arg $(mk (n 1)) |]
deriveDestructor :: Name -> [Type] -> Q Exp
deriveDestructor name tys = do
x <- newName "x"
r <- newName "r"
fieldNames <- replicateM (length tys) (newName "a")
nothing <- [| Nothing |]
ConE just <- [| Just |]
ConE left <- [| Left |]
ConE right <- [| Right |]
ConE cons <- [| (:-) |]
let conPat = ConP name (map VarP fieldNames)
let okBody = ConE just `AppE`
foldr
(\h t -> ConE cons `AppE` VarE h `AppE` t)
(VarE r)
fieldNames
let okCase = Match (ConP cons [conPat, VarP r]) (NormalB okBody) []
let nStr = show name
let failCase = Match WildP (NormalB nothing) []
return $ LamE [VarP x] (CaseE (VarE x) [okCase, failCase])
mkPrinterParserName :: Name -> Name
mkPrinterParserName name = mkName ('r' : nameBase name)
conName :: Con -> Name
conName con =
case con of
NormalC name _ -> name
RecC name _ -> name
InfixC _ name _ -> name
ForallC _ _ con' -> conName con'