kure-your-boilerplate 0.1.1 → 0.1.3
raw patch · 2 files changed
+198/−59 lines, 2 filesdep ~kurePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: kure
API changes (from Hackage documentation)
- Language.KURE.Boilerplate: kureYourBoilerplate :: Name -> Name -> Name -> Q [Dec]
+ Language.KURE.Boilerplate: kureYourBoilerplate :: Name -> [(Name, Name)] -> Q [Dec]
Files
- Language/KURE/Boilerplate.hs +195/−40
- kure-your-boilerplate.cabal +3/−19
Language/KURE/Boilerplate.hs view
@@ -37,7 +37,7 @@ -- -- An example of use is ----- > $(kureYourBoilerplate ''MyGeneric ''Id ''())+-- > $(kureYourBoilerplate ''MyGeneric [(''Id,''())]) -- -- Which means @MyGeneric@ is my universal type, @Id@ is my monad, and @()@ is my monoid. @@ -69,83 +69,134 @@ -- 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 m dec = do+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- tys <- case info of- TyConI (DataD _ _ _ cons _) -> do+ api_tys <- case info of+ TyConI (DataD _ _ _ cons _) -> do -- we look at *types* so that we can support more in the future.- let tys = [ argTy | (NormalC _ [(_,argTy)]) <- cons ]+ 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) -> + TyConI (TySynD _ [] singleTy) -> return [singleTy] -- no special generic instance needed- _ -> 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 ]+ _ -> 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 = [ AppE (VarE 'promoteR) (AppE (VarE nm) (VarE rr))- | (FunD nm _) <- allR'+ let altsR = [ mkPromote 'promoteR nm ty+ | (FunD nm _,ty) <- zip allR' api_resolved_tys ]- let altsU = [ AppE (VarE 'promoteU) (AppE (VarE nm) (VarE rr))- | (FunD nm _) <- allU'+ 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 -kureType :: Bool -> (Type,Type) -> [String] -> Type -> Q ([Dec],Dec,Dec)-kureType debug (m,dec) tyNames ty@(ConT nm) = do+-- 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- (decs,consNames,argCounts) <- liftM unzip3 $ sequence [ kureCons debug tyNames con | con <- 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))- [ AppE (VarE extract) (VarE rr)- | _ <- take argCount [(0::Int)..]+ [ mkExtract tyNames extract rr ty2+ | ty2 <- argTypes ]- | (consName,argCount) <- zip consNames argCounts+ | (consName,argTypes) <- zip consNames argTypess ]- let theInstance = InstanceD []+ 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 ( concat decs ++ [theInstance]+ return ( theInstances , 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)+-- 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")@@ -166,14 +217,22 @@ ] 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- ]+ 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 @@ -187,15 +246,16 @@ | (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 'rewrite) + let nameRExpr = AppE (VarE 'transparently)+ (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@@ -227,11 +287,11 @@ let nameP = mkName (combName consName ++ "P") the_e <- newName "the_e"- let namePExpr = AppE (VarE 'translate)+ let namePExpr = AppE (VarE 'transparently)+ (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)) )@@ -239,17 +299,112 @@ ) ) )- ) (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)+ 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 $ ""+
kure-your-boilerplate.cabal view
@@ -1,5 +1,5 @@ Name: kure-your-boilerplate-Version: 0.1.1+Version: 0.1.3 Synopsis: Generator for Boilerplate KURE Combinators Description: KURE-your-boilerplate is a Template Haskell powered library for generating shallow tree walking combinators, for use with the KURE DSL.@@ -9,31 +9,15 @@ License-file: LICENSE Author: Andy Gill Maintainer: Andy Gill <andygill@ku.edu>-Copyright: (c) 2008 Andy Gill+Copyright: (c) 2009 Andy Gill Homepage: http://ittc.ku.edu/~andygill/kure.php Stability: alpha build-type: Simple Cabal-Version: >= 1.6 Library- build-depends: base, kure >= 0.2.3, template-haskell+ build-depends: base, kure == 0.3.1, template-haskell Exposed-modules: Language.KURE.Boilerplate- Ghc-Options: -Wall-----Executable test1--- Main-Is: Test.hs--- Hs-Source-Dirs: ., test--- other-modules: Id, Exp--- buildable: True----Executable test2--- Main-Is: Test2.hs--- Hs-Source-Dirs: ., test--- other-modules: Id, Exp--- buildable: True--