diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Language/KURE/Boilerplate.hs b/Language/KURE/Boilerplate.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Boilerplate.hs @@ -0,0 +1,255 @@ +{-# 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 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 + [] -> "" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/kure-your-boilerplate.cabal b/kure-your-boilerplate.cabal new file mode 100644 --- /dev/null +++ b/kure-your-boilerplate.cabal @@ -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 +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 + + +