module Language.KURE.Boilerplate
( kureYourBoilerplate
)
where
import Language.KURE
import Language.Haskell.TH
import Data.Char
import Data.Monoid
import Control.Monad
import System.Environment
kureYourBoilerplate :: Name -> Name -> Name -> Q [Dec]
kureYourBoilerplate gname m dec = do
debug <- runIO $ (do _k_debug <- getEnv "KURE_DEBUG"
return $ True) `catch` (\ _ -> return False)
info <- reify gname
tys <- case info of
TyConI (DataD _ _ _ cons _) -> do
let tys = [ argTy | (NormalC _ [(_,argTy)]) <- cons ]
when (length tys /= length cons) $ do
fail $ "Strange type inside Generic datatype: " ++ show gname
return tys
TyConI (TySynD _ [] singleTy) ->
return [singleTy]
_ -> fail $ "problem with generic type name " ++ show gname
let tyNames = map pprint tys
(decs,allR',allU') <- liftM unzip3 $ sequence [ kureType debug (ConT m,ConT dec) tyNames ty | ty <- tys ]
rr <- newName "rr"
theOptGenericInstance <-
case info of
TyConI (DataD {}) -> do
let choice e1 e2 = InfixE (Just e1) (VarE '(<+)) (Just e2)
let altsR = [ AppE (VarE 'promoteR) (AppE (VarE nm) (VarE rr))
| (FunD nm _) <- allR'
]
let altsU = [ AppE (VarE 'promoteU) (AppE (VarE nm) (VarE rr))
| (FunD nm _) <- allU'
]
return [ InstanceD []
(foldl AppT (ConT ''Walker) [ConT m,ConT dec,ConT gname])
[ FunD (mkName "allR") [ Clause [VarP rr] (NormalB $ foldl1 choice altsR) allR']
, FunD (mkName "crushU") [ Clause [VarP rr] (NormalB $ foldl1 choice altsU) allU']
]
]
_ -> return []
let alldecs = concat decs ++ theOptGenericInstance
when debug $ runIO $ do putStrLn $ pprint alldecs
return $ alldecs
kureType :: Bool -> (Type,Type) -> [String] -> Type -> Q ([Dec],Dec,Dec)
kureType debug (m,dec) tyNames ty@(ConT nm) = do
info <- reify nm
cons <- case info of
TyConI (DataD _ _ _ cons _) -> return cons
_ -> fail $ "strange info on name " ++ show nm
(decs,consNames,argCounts) <- liftM unzip3 $ sequence [ kureCons debug tyNames con | con <- cons ]
rr <- newName "rr"
let buildFn name suffix extract = FunD name
[ Clause [VarP rr] (NormalB $ foldl1 choice alts) []]
where
choice e1 e2 = InfixE (Just e1) (VarE '(<+)) (Just e2)
alts = [ foldl AppE (VarE (mkName $ consName ++ suffix))
[ AppE (VarE extract) (VarE rr)
| _ <- take argCount [(0::Int)..]
]
| (consName,argCount) <- zip consNames argCounts
]
let theInstance = InstanceD []
(foldl AppT (ConT ''Walker) [m,dec,ty])
[ buildFn (mkName "allR") "R" 'extractR
, buildFn (mkName "crushU") "U" 'extractU
]
allR_nm <- newName "allR"
allU_nm <- newName "allU"
return ( concat decs ++ [theInstance]
, buildFn allR_nm "R" 'extractR
, buildFn allU_nm "U" 'extractU
)
kureType _debug _ _tyNames ty = fail $ "kureType: unsupported type :: " ++ show ty
kureCons :: Bool -> [String] -> Con -> Q ([Dec],String,Int)
kureCons _debug tyNames (NormalC consName args) = do
let guardName = mkName (combName consName ++ "G")
v <- newName "v"
let guardExpr = AppE (VarE 'acceptR) (LamE [VarP v]
(CaseE (VarE v)
[ Match (RecP consName [])
(NormalB (ConE 'True)) []
, Match WildP (NormalB (ConE 'False)) []
]))
let guardDef = ValD (VarP guardName) (NormalB guardExpr) []
let withName = mkName ("with" ++ nameBase consName)
(f:vs) <- mapM newName ("f": ["v" | _ <- args])
let withDef = FunD withName
[ Clause [VarP f,ConP consName (map VarP vs)] (NormalB (foldl AppE (VarE f) (map VarE vs))) []
, Clause [WildP,WildP] (NormalB (AppE (VarE 'failure) (LitE (StringL (show withName ++ " failed"))))) []
]
let nameR = mkName (combName consName ++ "R")
let interestingConsArgs =
[ case ty of
VarT {} -> error $ "found " ++ show ty ++ " as argument to " ++ show consName
ConT nm -> pprint nm `elem` tyNames
_ -> error $ "unsupported type " ++ show ty ++ " as argument to " ++ show consName
| ty <- argsTypes
]
rrs <- mapM newName [ "rr" | True <- interestingConsArgs ]
es <- mapM newName ["e" | _ <- args ]
es' <- sequence [ if interesting
then liftM Just $ newName "e'"
else return $ Nothing
| interesting <- interestingConsArgs ]
let es'' = [ case opt_e' of
Just e' -> e'
_ -> e
| (e,opt_e') <- zip es es'
]
let es'_rrs_es = [ (e',rr,e)
| (rr,(e,e')) <- zip rrs
[ (e,e') | (e,Just e') <- zip es es' ]
]
let nameRExpr = AppE (VarE 'rewrite)
(AppE (VarE withName)
(LamE (map VarP es)
(AppE (VarE 'transparently)
(DoE ( [ BindS (VarP e')
(foldl AppE (VarE 'apply) (map VarE [rr,e]))
| (e',rr,e) <- es'_rrs_es
]
++ [ NoBindS $
AppE (VarE 'return)
$ foldl AppE (ConE consName) (map VarE es'')
])))))
let nameRDef = FunD nameR [ Clause (map VarP rrs) (NormalB nameRExpr) []]
let nameU = mkName (combName consName ++ "U")
let nameUExpr = AppE (VarE 'translate)
(AppE (VarE withName)
(LamE (map VarP es)
(DoE ( [ BindS (VarP e')
(foldl AppE (VarE 'apply) (map VarE [rr,e]))
| (e',rr,e) <- es'_rrs_es
]
++ [ NoBindS $
AppE (VarE 'return)
$ AppE (VarE 'mconcat) (ListE (map VarE [ e' | Just e' <- es']))
]))))
let nameUDef = FunD nameU [ Clause (map VarP rrs) (NormalB nameUExpr) []]
let nameP = mkName (combName consName ++ "P")
the_e <- newName "the_e"
let namePExpr = AppE (VarE 'translate)
(LamE [VarP the_e]
(AppE (AppE (VarE withName)
(LamE (map VarP es)
(AppE (VarE 'transparently)
(AppE (AppE (VarE 'apply)
(foldl AppE (VarE f) (map VarE es))
)
(VarE the_e)
)
)
)
) (VarE the_e)
))
let namePDef = FunD nameP [ Clause [VarP f] (NormalB namePExpr) []]
return ([guardDef,withDef,nameRDef,nameUDef,namePDef],combName consName,length rrs)
where
argsTypes = map snd args
kureCons _ _tyNames other = error $ "Unsupported constructor : " ++ show other
combName :: Name -> String
combName nm = case nameBase nm of
(t:ts) -> toLower t : ts
[] -> ""