diff --git a/Language/KURE/Boilerplate.hs b/Language/KURE/Boilerplate.hs --- a/Language/KURE/Boilerplate.hs +++ b/Language/KURE/Boilerplate.hs @@ -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 $ "" + diff --git a/kure-your-boilerplate.cabal b/kure-your-boilerplate.cabal --- a/kure-your-boilerplate.cabal +++ b/kure-your-boilerplate.cabal @@ -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 -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 - -