{-# LANGUAGE TemplateHaskell #-}
-- |
-- Module: Language.KURE.Boilerplate
-- Copyright: (c) 2009 Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: ghc
--
-- This module contains a Template Haskell based generator for the many data-type specific
-- functions that KURE want users to write. KURE Your Boilerplate (KYB) attempts to make
-- writing these function easy. Eventually, there will be a small DSL for effects inside the
-- generated functions.
--
-- Unfortunately, you still need to write the 'Term' instance by hand, because of the use of
-- type families, a feature that post-dates Template Haskell. You also need to write
-- the single MyGeneric datatype, which is considered documentation of what you want
-- KYB to do.
--
-- 'kureYourBoilerplate' generates a 'Walker' instance for every data-type mentioned in your Generic,
-- a 'Walker' instance for the Generic type itself,
-- and the following for every constructor in every data-structure that is mentioned in Generic.
-- For exmaple if a constructor is called 'Foo', and has type @Foo :: A -> B -> C@, we generate
--
-- * @fooR :: (...) => R A -> R B -> R C --@ congruence over @Foo@.
--
-- * @fooU :: (...,Monoid r) => T A r -> T B r -> T C r --@ unify the interesting arguments of a @Foo@.
--
-- * @fooG :: (...) => R C --@ guard for the constructor @Foo@.
--
-- * @fooP :: (...) => (A -> B -> T C a) -> T C a --@ pattern matching on @Foo@.
--
-- * @withFoo :: (...,Failable f) => (A -> B -> f a) -> C -> f a --@ application and pattern matching on @Foo@.
--
-- Here, R is short for a 'Rewrite m dec', and 'T is short for 'Translate m dec'.
--
-- An example of use is
--
-- > $(kureYourBoilerplate ''MyGeneric [(''Id,''())])
--
-- Which means @MyGeneric@ is my universal type, @Id@ is my monad, and @()@ is my monoid.
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' generates a number of functions for each data-type mentioned in
-- our given Generic data-type, which we need to provide for KURE, as well as the
-- Walker instance.
--
-- The first argument is the name of the Generic data-structure, which you need to write by hand.
-- If you provide the name of a type synonym as the first argument, then KYB assumes that you are acting
-- over a single data-type, i.e. you generic is your AST type.
-- If you provide the name of a data-type (the typical use-case), then this function generates
-- code for every conceptual sub-type of the provided data-type.
--
-- The second argument is the monad over which you will be parameterizing your rewrite rules,
-- and the third argument is the monoid over which you will be parameterizing.
--
kureYourBoilerplate :: Name -> [(Name,Name)] -> Q [Dec]
kureYourBoilerplate gname at_types = do
debug <- runIO $ (do _k_debug <- getEnv "KURE_DEBUG"
return $ True) `catch` (\ _ -> return False)
info <- reify gname
api_tys <- case info of
TyConI (DataD _ _ _ cons _) -> do
-- we look at *types* so that we can support more in the future.
let (gcons,tys) = unzip [ (con,argTy) | (NormalC con [(_,argTy)]) <- cons ]
when (length tys /= length cons) $ do
fail $ "Strange type inside Generic datatype: " ++ show gname
mapM_ (pprintTermInstances gname) (zip gcons tys)
return tys
TyConI (TySynD _ [] singleTy) ->
return [singleTy] -- no special generic instance needed
_ -> fail $ "problem with generic type name " ++ show gname
runIO $ print ("(API_tys",api_tys)
runIO $ putStrLn "---------------------------------"
api_resolved_tys <- mapM resolveSynomyn api_tys
runIO $ print ("(tyNames",api_resolved_tys)
runIO $ putStrLn "---------------------------------"
(decs,allR',allU') <- liftM unzip3 $ sequence [ kureType debug [ (ConT m,ConT dec) | (m,dec) <- at_types]
(map pprint api_resolved_tys) rty ty
| (rty,ty) <- zip api_resolved_tys api_tys
]
rr <- newName "rr"
-- Here, we find a way to promote from the generic type to specific type(s).
let mkPromote prom nm _ty = AppE (VarE prom) (AppE (VarE nm) (VarE rr))
theOptGenericInstance <-
case info of
TyConI (DataD {}) -> do
let choice e1 e2 = InfixE (Just e1) (VarE '(<+)) (Just e2)
let altsR = [ mkPromote 'promoteR nm ty
| (FunD nm _,ty) <- zip allR' api_resolved_tys
]
let altsU = [ mkPromote 'promoteU nm ty
| (FunD nm _,ty) <- zip allU' api_resolved_tys
]
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']
]
| (m,dec) <- at_types
]
_ -> return []
let alldecs = concat decs ++ theOptGenericInstance
when debug $ runIO $ do putStrLn $ pprint alldecs
-- let msg
return $ alldecs
-- A type for which we want an API for a generic allR, etc.
kureType :: Bool -> [(Type,Type)] -> [String] -> Type -> Type -> Q ([Dec],Dec,Dec)
kureType debug at_ty tyNames ty@(ConT nm) _orig_type = do
info <- reify nm
cons <- case info of
TyConI (DataD _ _ _ cons _) -> return cons
_ -> fail $ "strange info on name " ++ show nm ++ " : " ++ show info
(decs,consNames,argTypess) <- 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))
[ mkExtract tyNames extract rr ty2
| ty2 <- argTypes
]
| (consName,argTypes) <- zip consNames argTypess
]
let theInstances = [ InstanceD []
(foldl AppT (ConT ''Walker) [m,dec,ty])
[ buildFn (mkName "allR") "R" R
, buildFn (mkName "crushU") "U" U
]
| (m,dec) <- at_ty
]
allR_nm <- newName "allR"
allU_nm <- newName "allU"
return ( concat decs ++ theInstances
, buildFn allR_nm "R" R
, buildFn allU_nm "U" U
)
-- A bit of a hack for now
kureType _debug at_ty _tyNames ty ty2 = do
-- For other types, we do not generate the G,U, etc, functions, but do define
-- the *all* instance, which works directly over the type.
rr <- newName "rr"
tup <- newName "x"
let buildFn name suffix extract = FunD name
[ Clause [VarP rr] (NormalB
$ (if suffix == "R" then AppE (VarE 'transparently) else id)
$ AppE (VarE 'translate)
$ LamE [VarP tup]
$ AppE ( AppE (VarE 'apply)
(AppE (VarE extract) (VarE rr))
)
(SigE (VarE tup) ty2)
) []]
let theInstances = [ InstanceD []
(foldl AppT (ConT ''Walker) [m,dec,ty])
[ buildFn (mkName "allR") "R" 'extractR
, buildFn (mkName "crushU") "U" 'extractU
]
| (m,dec) <- at_ty ]
allR_nm <- newName "allR"
allU_nm <- newName "allU"
return ( theInstances
, buildFn allR_nm "R" 'extractR
, buildFn allU_nm "U" 'extractU
)
-- kureType _debug _ _tyNames ty ty2 = fail $ "kureType: unsupported type :: " ++ pprint ty ++ " ( " ++ pprint ty2 ++ " )"
kureCons :: Bool -> [String] -> Con -> Q ([Dec],String,[Type])
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 isInteresting ty@(VarT {}) _ = error $ "found " ++ pprint ty ++ " as argument to " ++ show consName
isInteresting ty [] | pprint ty `elem` tyNames
= True
isInteresting (ConT _nm) [] = False -- the above case caught this
isInteresting (ConT nm) [inner_ty]
| nm == ''[] = isInteresting inner_ty []
| nm == ''Maybe = isInteresting inner_ty []
isInteresting (ConT nm) tys
| length tys >= 2 && nm == tupleTypeName (length tys) = or [ isInteresting ty [] | ty <- tys ]
isInteresting (AppT e1 e2) es = isInteresting e1 (e2:es)
isInteresting ty _ = error $ "unsupported type " ++ pprint ty ++ " as argument to " ++ show consName
resolvedArgsTypes <- mapM resolveSynomyn argsTypes
-- This denotes if the 'R' combinator and 'U' combinator will have an explicitly called out argument.
let interestingConsArgs = [ isInteresting ty [] | ty <- resolvedArgsTypes ]
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'
]
-- eek, this wiring is undocumented.
let es'_rrs_es = [ (e',rr,e)
| (rr,(e,e')) <- zip rrs
[ (e,e') | (e,Just e') <- zip es es' ]
]
let nameRExpr = AppE (VarE 'transparently)
(AppE (VarE 'rewrite)
(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)
$ 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 nameRDef = ValD (VarP nameR) (NormalB nameRExpr) []
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 'transparently)
(AppE (VarE 'translate)
(LamE [VarP the_e]
(AppE (AppE (VarE withName)
(LamE (map VarP es)
(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
, [ ty | (True,ty) <- zip interestingConsArgs resolvedArgsTypes ]
)
where
argsTypes = map snd args
kureCons _ _tyNames other = error $ "Unsupported constructor : " ++ show other
mkExtract :: [String] -> ResultStyle -> Name -> Type -> Exp
mkExtract tyNames extract rr ty | pprint ty `elem` tyNames
= AppE (VarE $ theExtract extract) (VarE rr)
mkExtract tyNames extract rr (AppT e1 e2) = mkExtract' tyNames extract rr e1 [e2]
mkExtract _tyNames _extract _rr ty = error $ "failed to make extract for " ++ pprint ty
mkExtract' :: [String] -> ResultStyle -> Name -> Type -> [Type] -> Exp
mkExtract' tyNames extract rr (AppT e1 e2) es = mkExtract' tyNames extract rr e1 (e2:es)
mkExtract' tyNames extract rr (ConT con) [t1,t2]
| con == tupleTypeName 2 = AppE (AppE (VarE $ theTuple2 extract)
(mkExtract tyNames extract rr t1)
) (mkExtract tyNames extract rr t2)
mkExtract' tyNames extract rr (ConT con) [t1]
| con == ''[] = AppE (VarE $ theList extract)
(mkExtract tyNames extract rr t1)
mkExtract' tyNames extract rr (ConT con) [t1]
| con == ''Maybe = AppE (VarE $ theMaybe extract)
(mkExtract tyNames extract rr t1)
mkExtract' _tyNames _extract _rr ty _ = error $ "failed to make extract for " ++ pprint ty
data ResultStyle = R | U
-- Perhaps a fixed table?
theExtract :: ResultStyle -> Name
theExtract R = 'extractR
theExtract U = 'extractU
theTuple2 :: ResultStyle -> Name
theTuple2 R = 'tuple2R
theTuple2 U = 'tuple2U
theList :: ResultStyle -> Name
theList R = 'listR
theList U = 'listU
theMaybe :: ResultStyle -> Name
theMaybe R = 'maybeR
theMaybe U = 'maybeU
combName :: Name -> String
combName nm = case nameBase nm of
(t:ts) -> toLower t : ts
[] -> ""
resolveSynomyn:: Type -> Q Type
resolveSynomyn ty@(ConT con) = do
info <- reify con
-- runIO $ print info
case info of
TyConI (DataD _ _ _ _ _) -> return $ ty
TyConI (NewtypeD _ _ _ _ _) -> return $ ty
TyConI (TySynD _ [] ty2) -> resolveSynomyn ty2
_ -> fail $ "unknown info inside " ++ show con ++ " ( " ++ show info ++ ")"
-- fail $ "resolveSynomyn problem : " ++ show other
resolveSynomyn (AppT e1 e2) = do
e1' <- resolveSynomyn e1
e2' <- resolveSynomyn e2
return $ AppT e1' e2'
resolveSynomyn other = fail $ "resolveSynomyn problem : " ++ show other
{-
typeToSuffix :: Type -> String
typeToSuffix (ConT con) = nameBase con
typeToSuffix (AppT e1 e2) = typesToSuffix e1 [e2]
typeToSuffix ty = error $ "typeToSuffix failure with " ++ show ty
typeToSuffix :: Type -> [Type] -> String
typesToSuffix (ConT con) es
| length es /= 1 && con == tupleTypeName (length es) = typesToSuffix (TupleT $ length es) es
| length es == 1 && con == ''[] = typesToSuffix ListT es
typesToSuffix (ListT) [e1] = "ListOf_" ++ typeToSuffix e1
typesToSuffix (TupleT i) [] = "'Unit'"
typesToSuffix (TupleT i) es = show i ++ "TupleOf_" ++
foldr1 (\ a b -> a ++ "_And_" ++ b)
(map typeToSuffix es)
typesToSuffix (AppT e1 e2) es = typesToSuffix e1 (e2:es)
typesToSuffix ty _ = error $ "typesToSuffix failure with " ++ show ty
-}
pprintTermInstances :: Name -> (Name,Type) -> Q ()
pprintTermInstances gnm (nm,ty) =
runIO $ do
putStrLn $ ""
putStrLn $ "--------------------------------------------------"
putStrLn $ "instance Term " ++ pprint ty ++ " where"
putStrLn $ " type Generic " ++ pprint ty ++ " = " ++ nameBase gnm
putStrLn $ " select (" ++ nameBase nm ++ " e) = Just e"
putStrLn $ " select _ = Nothing"
putStrLn $ " inject = " ++ nameBase nm
putStrLn $ "--------------------------------------------------"
putStrLn $ ""