{-# LANGUAGE TemplateHaskell #-} -- | -- Module: Language.KURE.Boilerplate -- Copyright: (c) 2009 Andy Gill -- License: BSD3 -- -- Maintainer: Andy Gill -- 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 $ ""