kure-your-boilerplate (empty) → 0.1.1
raw patch · 4 files changed
+321/−0 lines, 4 filesdep +basedep +kuredep +template-haskellsetup-changed
Dependencies added: base, kure, template-haskell
Files
- LICENSE +25/−0
- Language/KURE/Boilerplate.hs +255/−0
- Setup.hs +2/−0
- kure-your-boilerplate.cabal +39/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2008-2009 Andy Gill+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The names of the authors may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Language/KURE/Boilerplate.hs view
@@ -0,0 +1,255 @@+{-# 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 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+ -- we look at *types* so that we can support more in the future.+ 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] -- 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 ]++ 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 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 '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+ [] -> ""
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ kure-your-boilerplate.cabal view
@@ -0,0 +1,39 @@+Name: kure-your-boilerplate+Version: 0.1.1+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.++Category: Language+License: BSD3+License-file: LICENSE+Author: Andy Gill+Maintainer: Andy Gill <andygill@ku.edu>+Copyright: (c) 2008 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+ 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+++