kure 0.3.1 → 2.0.0
raw patch · 23 files changed
+1715/−572 lines, 23 filesdep ~basesetup-changednew-uploader
Dependency ranges changed: base
Files
- LICENSE +1/−1
- Language/KURE.hs +14/−15
- Language/KURE/Combinators.hs +112/−160
- Language/KURE/Injection.hs +110/−0
- Language/KURE/Rewrite.hs +0/−46
- Language/KURE/RewriteMonad.hs +0/−165
- Language/KURE/Term.hs +0/−115
- Language/KURE/Translate.hs +208/−49
- Language/KURE/Utilities.hs +176/−0
- Language/KURE/Walker.hs +187/−0
- Setup.hs +0/−2
- Setup.lhs +2/−0
- examples/Examples.hs +21/−0
- examples/Expr/AST.hs +31/−0
- examples/Expr/Examples.hs +75/−0
- examples/Expr/Kure.hs +202/−0
- examples/Fib/AST.hs +18/−0
- examples/Fib/Examples.hs +122/−0
- examples/Fib/Kure.hs +42/−0
- examples/Lam/AST.hs +67/−0
- examples/Lam/Examples.hs +216/−0
- examples/Lam/Kure.hs +74/−0
- kure.cabal +37/−19
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2006-2009 Andy Gill+(c) 2006-2012 The University of Kansas All rights reserved. Redistribution and use in source and binary forms, with or without
Language/KURE.hs view
@@ -1,26 +1,25 @@ -- | -- Module: Language.KURE--- Copyright: (c) 2006-2008 Andy Gill+-- Copyright: (c) 2012 The University of Kansas -- License: BSD3 ----- Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta -- Portability: ghc -- -- This is the main import module for KURE, which exports all the major components.---+-- The basic transformation functionality can be found in "Language.KURE.Translate",+-- and the traversal functionality can be found in "Language.KURE.Walker". --+-- Note that "Language.KURE.Injection" and "Language.KURE.Utilities" are not exported here, but can be imported seperately. -module Language.KURE - ( module Language.KURE.RewriteMonad- , module Language.KURE.Translate- , module Language.KURE.Rewrite- , module Language.KURE.Combinators- , module Language.KURE.Term- ) where -import Language.KURE.RewriteMonad-import Language.KURE.Translate-import Language.KURE.Rewrite+module Language.KURE+ ( module Language.KURE.Translate+ , module Language.KURE.Walker+ , module Language.KURE.Combinators+) where+ import Language.KURE.Combinators-import Language.KURE.Term+import Language.KURE.Translate+import Language.KURE.Walker
Language/KURE/Combinators.hs view
@@ -1,193 +1,145 @@+{-# LANGUAGE TypeOperators, TupleSections #-}+ -- |--- Module: Language.KURE.Combinators --- Copyright: (c) 2006-2008 Andy Gill+-- Module: Language.KURE.Combinators+-- Copyright: (c) 2012 The University of Kansas -- License: BSD3 ----- Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta -- Portability: ghc ----- This module contains various combinators that use 'Translate' and 'Rewrite'. The convension is that--- 'Translate' based combinators end with @T@, and 'Rewrite' based combinators end with @R@. Of course,--- because 'Rewrite' is a type synomim of 'Translate', the 'Rewrite' functions also operate with on 'Translate',--- and the 'Translate' functions operate with 'Rewrite'. --module Language.KURE.Combinators - ( -- * The 'Translate' combinators- (<+)- , (>->)- , failT- , readerT- , readEnvT- , mapEnvT- , writeEnvT- , pureT- , constT- , concatT- , -- * The 'Rewrite' combinators- (.+)- , (!->)- , tryR- , changedR- , repeatR- , acceptR- , idR- , failR- , -- * The Prelude combinators- tuple2R- , listR- , maybeR- , tuple2U- , listU- , maybeU- , -- * Generic failure, over both 'Monad's and 'Translate's.- (?)- , Failable(..)- ) where - -import Language.KURE.RewriteMonad -import Language.KURE.Translate -import Language.KURE.Rewrite -import Data.Monoid-import Control.Monad--infixl 3 <+, >->, .+, !->-infixr 3 ?---- Note: We use < for catching fail, . for catching id.------------------------------------------------------------------------------------- The Translate combinators.---- | like a catch, '<+' does the first translate , and if it fails, then does the second translate. -(<+) :: (Monoid dec, Monad m) => Translate m dec a b -> Translate m dec a b -> Translate m dec a b-(<+) rr1 rr2 = transparently $ translate $ \ e -> apply rr1 e `catchM` (\ _ -> apply rr2 e)---- | like a @;@ If the first translate succeeds, then do to the second translate after the first translate.-(>->) :: (Monoid dec, Monad m) => Translate m dec a b -> Translate m dec b c -> Translate m dec a c-(>->) rr1 rr2 = transparently $ translate $ \ e -> chainM (apply rr1 e) ( \ _i e2 -> apply rr2 e2)---- | failing translation.-failT :: (Monad m, Monoid dec) => String -> Translate m dec a b-failT msg = translate $ \ _ -> failM msg----- | look at the argument for the translation before choosing which translation to perform. -readerT :: (Monoid dec, Monad m) => (a -> Translate m dec a b) -> Translate m dec a b-readerT fn = transparently $ translate $ \ expA -> apply (fn expA) expA+-- This module provides various monadic and arrow combinators that are particularly useful when+-- working with translations.+-- Note that these combinators assume that 'mplus' behaves as a catch, for both 'fail' and 'mzero'. --- | look at the @dec@ before choosing which translation to do.-readEnvT :: (Monad m, Monoid dec) => (dec -> Translate m dec a b) -> Translate m dec a b-readEnvT f = transparently $ translate $ \ e -> - do dec <- readEnvM - apply (f dec) e+module Language.KURE.Combinators+ ( -- * Monad Combinators+ guardFail+ , condM+ , whenM+ , tryM+ , mtryM+ , attemptM+ , testM+ , notM+ -- * Arrow Combinators+ -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators.+ , result+ , argument+ , idR+ , (<+)+ , readerR+ , acceptR+ , tryR+ , attemptR+ , changedR+ , repeatR+ , (>+>)+ , orR+ , andR+) where --- | add to the context 'dec', which is propogated using a writer monad.-writeEnvT :: (Monad m, Monoid dec) => dec -> Rewrite m dec a-writeEnvT dec = translate $ \ e -> do writeEnvM dec ; return e+import Prelude hiding (id , (.))+import Control.Monad+import Control.Category+import Control.Arrow+import Data.Maybe (isJust)+import Data.Monoid --- | change the @dec@'s for a scoped translation.-mapEnvT :: (Monoid dec,Monad m) => (dec -> dec) -> Translate m dec a r -> Translate m dec a r-mapEnvT f_env rr = transparently $ translate $ \ e -> mapEnvM f_env (apply rr e)+infixl 3 <+, >+> --- | 'pureT' promotes a function into an unfailable, non-identity 'Translate'.-pureT :: (Monad m,Monoid dec) => (a -> b) -> Translate m dec a b-pureT f = translate $ \ a -> return (f a)+------------------------------------------------------------------------------------------ --- | 'constT' always translates into an unfailable 'Translate' that returns the first argument.-constT :: (Monad m,Monoid dec) => b -> Translate m dec a b-constT = pureT . const+-- | Similar to 'guard', but using 'fail' rather than 'mzero'.+guardFail :: Monad m => Bool -> String -> m ()+guardFail b msg = unless b (fail msg) --- | 'concatT' composes a list of 'Translate' into a single 'Translate' which 'mconcat's its result.-concatT :: (Monad m,Monoid dec,Monoid r) => [Translate m dec a r] -> Translate m dec a r-concatT ts = translate $ \ e -> do- rs <- sequence [ apply t e | t <- ts ]- return (mconcat rs)------------------------------------------------------------------------------------ The 'Rewrite' combinators.+-- | if-then-else lifted over a 'Monad'.+condM :: Monad m => m Bool -> m a -> m a -> m a+condM mb m1 m2 = do b <- mb+ if b then m1 else m2 --- | if the first rewrite is an identity, then do the second rewrite.-(.+) :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a -> Rewrite m dec a-(.+) a b = a `countTrans` (\ i -> if i == 0 then b else idR)+-- | if-then lifted over a 'Monad'.+whenM :: Monad m => m Bool -> m a -> m a+whenM mb ma = condM mb ma (fail "condition False") --- | if the first rewrite was /not/ an identity, then also do the second rewrite.-(!->) :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a -> Rewrite m dec a -(!->) a b = a `countTrans` (\ i -> if i == 0 then idR else b)+-- | Catch a failing monadic computation, making it succeed with a constant value.+tryM :: MonadPlus m => a -> m a -> m a+tryM a ma = ma `mplus` return a --- | catch a failing 'Rewrite', making it into an identity.-tryR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a-tryR s = s <+ idR+-- | Catch a failing monadic computation, making it succeed with 'mempty'.+mtryM :: (MonadPlus m, Monoid a) => m a -> m a+mtryM = tryM mempty --- | if this is an identity rewrite, make it fail. To succeed, something must have changed.-changedR :: (Monoid dec,Monad m) => Rewrite m dec a -> Rewrite m dec a-changedR rr = rr .+ failR "unchanged"+-- | Catch a failing monadic computation, making it succeed with 'Nothing'.+attemptM :: MonadPlus m => m a -> m (Maybe a)+attemptM = tryM Nothing . liftM Just --- | repeat a rewrite until it fails, then return the result before the failure.-repeatR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a-repeatR s = tryR (s >-> repeatR s) +-- | Determine if a monadic computation succeeds.+testM :: MonadPlus m => m a -> m Bool+testM = liftM isJust . attemptM --- | look at the argument to a rewrite, and choose to be either a failure of trivial success.-acceptR :: (Monoid dec, Monad m) => (a -> Bool) -> Rewrite m dec a-acceptR fn = transparently $ translate $ \ expA ->- if fn expA - then return expA- else fail "accept failed"+-- | Fail if the 'Monad' succeeds; succeed with @()@ if it fails.+notM :: MonadPlus m => m a -> m ()+notM ma = attemptM ma >>= maybe (return ()) (const mzero) +------------------------------------------------------------------------------------------ --- | identity rewrite.-idR :: (Monad m, Monoid dec) => Rewrite m dec exp-idR = transparently $ rewrite $ \ e -> return e+-- | Apply a pure function to the result of an 'Arrow'.+result :: Arrow (~>) => (b -> c) -> (a ~> b) -> (a ~> c)+result f a = a >>^ f --- | failing rewrite.-failR :: (Monad m, Monoid dec) => String -> Rewrite m dec a-failR = failT+-- | Apply a pure function to the argument to an 'Arrow'.+argument :: Arrow (~>) => (a -> b) -> (b ~> c) -> (a ~> c)+argument f a = f ^>> a ------------------------------------------------------------------------------------ Prelude structures+------------------------------------------------------------------------------- -tuple2R :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec b -> Rewrite m dec (a,b)-tuple2R rra rrb = transparently $ rewrite $ \ (a,b) -> liftM2 (,) (apply rra a) (apply rrb b)+-- | Synonym for 'id'.+idR :: Category (~>) => (a ~> a)+idR = id -listR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec [a]-listR rr = transparently $ rewrite $ mapM (apply rr)+-- | Synonym for '<+>'.+(<+) :: ArrowPlus (~>) => (a ~> b) -> (a ~> b) -> (a ~> b)+(<+) = (<+>) -maybeR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec (Maybe a)-maybeR rr = transparently $ rewrite $ \ e -> case e of- Just e' -> liftM Just (apply rr e')- Nothing -> return $ Nothing+-- | Look at the argument to the 'Arrow' before choosing which 'Arrow' to use.+readerR :: ArrowApply (~>) => (a -> (a ~> b)) -> (a ~> b)+readerR f = (f &&& id) ^>> app -tuple2U :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec b r -> Translate m dec (a,b) r-tuple2U rra rrb = translate $ \ (a,b) -> liftM2 mappend (apply rra a) (apply rrb b)+-- | Look at the argument to an 'Arrow', and choose to be either the identity arrow or the zero arrow.+acceptR :: (ArrowZero (~>), ArrowApply (~>)) => (a -> Bool) -> (a ~> a)+acceptR p = readerR $ \ a -> if p a then id else zeroArrow -listU :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec [a] r-listU rr = translate $ liftM mconcat . mapM (apply rr)+-- | Catch a failing 'ArrowPlus', making it into an identity.+tryR :: ArrowPlus (~>) => (a ~> a) -> (a ~> a)+tryR r = r <+> id -maybeU :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec (Maybe a) r-maybeU rr = translate $ \ e -> case e of- Just e' -> apply rr e'- Nothing -> return $ mempty+-- | Catch a failing 'ArrowPlus', making it succeed with a Boolean flag.+-- Useful when defining 'anyR' instances.+attemptR :: ArrowPlus (~>) => (a ~> a) -> (a ~> (Bool,a))+attemptR r = (r >>^ (True,)) <+> arr (False,) ------------------------------------------------------------------------------------ | Failable structure.-class Failable f where- failure :: String -> f a+-- | Makes an 'Arrow' fail if the result value equals the argument value.+changedR :: (ArrowPlus (~>), ArrowApply (~>), Eq a) => (a ~> a) -> (a ~> a)+changedR r = readerR (\ a -> r >>> acceptR (/=a)) -instance (Monad m, Monoid dec) => Failable (Translate m dec a) where - failure msg = failT msg+-- | Repeat an 'ArrowPlus' until it fails, then return the result before the failure.+-- Requires at least the first attempt to succeed.+repeatR :: ArrowPlus (~>) => (a ~> a) -> (a ~> a)+repeatR r = r >>> tryR (repeatR r) -instance (Monad m, Monoid dec) => Failable (RewriteM m dec) where - failure msg = fail msg- --- | Guarded translate or monadic action.-(?) :: (Failable f) => Bool -> f a -> f a-(?) False _rr = failure "(False ?)"-(?) True rr = rr+-- | Attempts two 'Arrows's in sequence, succeeding if one or both succeed.+(>+>) :: (ArrowPlus (~>), ArrowApply (~>)) => (a ~> a) -> (a ~> a) -> (a ~> a)+r1 >+> r2 = attemptR r1 >>> readerR (\ (b,_) -> snd ^>> if b then tryR r2 else r2) +-- | Sequence a list of 'Arrow's, succeeding if any succeed.+orR :: (ArrowZero (~>), ArrowPlus (~>), ArrowApply (~>)) => [a ~> a] -> (a ~> a)+orR = foldl (>+>) zeroArrow ------------------------------------------------------------------------------------ internal to this module.-countTrans :: (Monoid dec, Monad m) => Rewrite m dec a -> (Int -> Rewrite m dec a) -> Rewrite m dec a-countTrans rr fn = transparently $ translate $ \ e ->- chainM (apply rr e)- (\ i e' -> apply (fn i) e')+-- | Sequence a list of 'Arrow's, succeeding if they all succeed.+andR :: Arrow (~>) => [a ~> a] -> (a ~> a)+andR = foldl (>>>) id +-------------------------------------------------------------------------------
+ Language/KURE/Injection.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- |+-- Module: Language.KURE.Injection+-- Copyright: (c) 2012 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides a type class for injective functions (and their retractions),+-- and some useful interactions with 'Translate'.+--+-- A particularly useful instance of 'Injection' is from @a@ to 'Generic' @a@,+-- and that case is the primary purpose of most of these combinators.++module Language.KURE.Injection+ ( -- * Injection Class+ Injection(..)+ -- * Monad Injections+ , injectM+ , retractM+ -- * Translate Injections+ , injectT+ , retractT+ , extractT+ , promoteT+ , extractR+ , promoteR+ -- * Lens Injections+ , injectL+ , retractL+) where++import Control.Monad+import Control.Arrow++import Language.KURE.Translate++-------------------------------------------------------------------------------++-- | A class of injective functions from @a@ to @b@, and their retractions.+-- The following law is expected to hold:+--+-- > retract (inject a) == Just a++class Injection a b where+ inject :: a -> b+ retract :: b -> Maybe a++-- | There is an identity injection for all types.+instance Injection a a where+ inject = id+ retract = Just++instance Injection a (Maybe a) where+ inject = Just+ retract = id++-------------------------------------------------------------------------------++-- | Injects a value and lifts it into a 'Monad'.+injectM :: (Monad m, Injection a a') => a -> m a'+injectM = return . inject++-- | Retracts a value and lifts it into a 'MonadPlus', producing 'mzero' if the retraction fails.+retractM :: (MonadPlus m, Injection a a') => a' -> m a+retractM = maybe mzero return . retract++-------------------------------------------------------------------------------++-- | Lifted 'inject'.+injectT :: (Monad m, Injection a a') => Translate c m a a'+injectT = arr inject++-- | Lifted 'retract', the 'Translate' fails if the retraction fails.+retractT :: (MonadPlus m, Injection a a') => Translate c m a' a+retractT = contextfreeT retractM++-- | Convert a 'Translate' over an injected value into a 'Translate' over a non-injected value.+extractT :: (Monad m, Injection a a') => Translate c m a' b -> Translate c m a b+extractT t = injectT >>> t++-- | Promote a 'Translate' over a value into a 'Translate' over an injection of that value,+-- (failing if that injected value cannot be retracted).+promoteT :: (MonadPlus m, Injection a a') => Translate c m a b -> Translate c m a' b+promoteT t = retractT >>> t++-- | Convert a 'Rewrite' over an injected value into a 'Rewrite' over a retraction of that value,+-- (failing if that injected value cannot be retracted).+extractR :: (MonadPlus m, Injection a a') => Rewrite c m a' -> Rewrite c m a+extractR r = injectT >>> r >>> retractT++-- | Promote a 'Rewrite' into over a value into a 'Rewrite' over an injection of that value,+-- (failing if that injected value cannot be retracted).+promoteR :: (MonadPlus m, Injection a a') => Rewrite c m a -> Rewrite c m a'+promoteR r = retractT >>> r >>> injectT++-------------------------------------------------------------------------------++-- | A 'Lens' to the injection of a value.+injectL :: (MonadPlus m, Injection a a') => Lens c m a a'+injectL = lens $ \ c a -> return ((c, inject a), retractM)++-- | A 'Lens' to the retraction of a value.+retractL :: (MonadPlus m, Injection a a') => Lens c m a' a+retractL = lens $ \ c -> retractM >=> (\ a -> return ((c,a), injectM))++-------------------------------------------------------------------------------
− Language/KURE/Rewrite.hs
@@ -1,46 +0,0 @@--- |--- Module: Language.KURE.Rewrite --- Copyright: (c) 2006-2008 Andy Gill--- License: BSD3------ Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable--- Portability: ghc------ 'Rewrite' is a synonoym for a 'Translate' with the same source and target type.--- This module contains the defintion of Rewrite, and some aliases for some translate functions that use --- Rewrite rather than Translate.--module Language.KURE.Rewrite - ( Rewrite- , rewrite- , runRewrite- ) where--import Language.KURE.RewriteMonad-import Language.KURE.Translate-import Data.Monoid---- | A 'Rewrite' is a 'Translate' that shares the same source and target type. Literally, --- a 'Rewrite' provides the details about how to /re-write/ a specific type.--type Rewrite m dec exp = Translate m dec exp exp---- | 'rewrite' is our primitive way of building a Rewrite,--- where if the rewrite is successful it is automatically marked as a non-identity rewrite. ------ @rewrite $ \\ _ e -> return e@ /is not/ an identity rewrite. --rewrite :: (Monoid dec, Monad m) => (exp1 -> RewriteM m dec exp1) -> Rewrite m dec exp1-rewrite = translate---- | 'runRewrite' executes the rewrite, returning either a failure message,--- or a success and the new parts of the environment.---runRewrite :: (Monoid dec,Monad m) - => Rewrite m dec exp- -> dec - -> exp - -> m (Either String (exp,dec,Int))-runRewrite = runTranslate
− Language/KURE/RewriteMonad.hs
@@ -1,165 +0,0 @@--- |--- Module: Language.KURE.RewriteMonad --- Copyright: (c) 2006-2008 Andy Gill--- License: BSD3------ Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable--- Portability: ghc------ This is the definition of the monad inside KURE.--module Language.KURE.RewriteMonad - ( RewriteM -- abstract- , RewriteStatusM(..)- , Count(..)- , theCount- , runRewriteM- , failM- , catchM- , chainM- , liftQ- , markM- , transparentlyM- , readEnvM- , mapEnvM- , writeEnvM- ) where ---import Control.Monad-import Data.Monoid----------------------------------------------------------------------------------data RewriteM m dec exp = - RewriteM { -- | 'runRewriteM' runs the 'RewriteM' monad, returning a status.- runRewriteM :: dec -> m (RewriteStatusM dec exp) - }---data Count = LoneTransform- | Count !Int---- | How many transformations have been performed?--theCount :: Count -> Int -theCount (LoneTransform) = 1-theCount (Count n) = n--instance Monoid Count where- mempty = Count 0-- mappend (Count 0) other = other- mappend other (Count 0) = other- mappend (Count i1) (Count i2) = Count (i1 + i2)- mappend (LoneTransform) (Count i2) = Count $ succ i2- mappend (Count i1) (LoneTransform) = Count $ succ i1- mappend (LoneTransform) (LoneTransform) = Count $ 2--data RewriteStatusM dec exp- = RewriteReturnM exp !(Maybe dec) !Count -- ^ a regular success- | RewriteFailureM String -- ^ a real failure--- | RewriteIdM exp -- ^ identity marker on a value----- TWO possible ways of thinking about rewriting:---- C1 (e1) => C2 (C1 (e2)) => C3 (C2 (C1 (e3))) -- matches the *writer* like status--- C1 (e1) => C1 (C2 (e2)) => C1 (C2 (C3 (e3))) -- will require mergeing??--instance (Monoid dec,Monad m) => Monad (RewriteM m dec) where- return e = RewriteM $ \ _ -> return $ RewriteReturnM e Nothing mempty- (RewriteM m) >>= k = RewriteM $ \ dec -> do- r <- m dec- case r of- RewriteReturnM r1 ds ids -> do- r2 <- runRewriteM (k r1) dec- return $ case r2 of- RewriteReturnM e' ds' ids' -> RewriteReturnM e' (ds' `mappend` ds) (ids' `mappend` ids)- RewriteFailureM msg -> RewriteFailureM msg- RewriteFailureM msg -> return $ RewriteFailureM msg-- fail msg = RewriteM $ \ _ -> return $ RewriteFailureM msg--instance (Monoid dec,Monad m) => Functor (RewriteM m dec) where- fmap f m = liftM f m---- | 'liftQ' lets you tunnel into the inner monad, because 'RewriteM' is actually monad transformer.-liftQ :: (Monad m,Monoid dec) => m a -> RewriteM m dec a -liftQ m = RewriteM $ \ _ -> do r <- m- return $ RewriteReturnM r mempty mempty---- | 'failM' is our basic failure, with a String message.-failM :: (Monad m, Monoid dec) => String -> RewriteM m dec a-failM msg = RewriteM $ \ _ -> return $ RewriteFailureM msg---- | 'catchM' catches failures, and tries a second monadic computation.-catchM :: (Monad m) => RewriteM m dec a -> (String -> RewriteM m dec a) -> RewriteM m dec a-catchM (RewriteM m1) m2 = RewriteM $ \ dec -> do- r <- m1 dec- case r of- RewriteReturnM {} -> return r - RewriteFailureM msg -> runRewriteM (m2 msg) dec- - --- | 'chainM' executes the first argument then the second, much like '>>=',--- except that the second computation can see if the first computation was an identity or not.--- Used to spot when a rewrite succeeded, but was the identity.--chainM :: (Monoid dec,Monad m) - => (RewriteM m dec b) - -> (Int -> b -> RewriteM m dec c)- -> RewriteM m dec c-chainM m k = RewriteM $ \ dec -> do- r <- runRewriteM m dec- case r of- RewriteReturnM a ds ids -> - do r2 <- runRewriteM (k (theCount ids) a) - (case ds of- Nothing -> dec- Just ds2 -> ds2 `mappend` dec)- case r2 of- RewriteReturnM a' ds' ids' ->- return $ RewriteReturnM a' (ds' `mappend` ds) (ids' `mappend` ids)- RewriteFailureM msg -> return $ RewriteFailureM msg- RewriteFailureM msg -> return $ RewriteFailureM msg -- and still fail --- --- | 'markM' is used to mark a monadic rewrite as a non-identity,--- unless the congruence flag is set.-markM :: (Monad m) => RewriteM m dec a -> RewriteM m dec a-markM (RewriteM m) = RewriteM $ \ dec -> do- r <- m dec- case r of- RewriteReturnM a ds (Count 0) -> return $ RewriteReturnM a ds LoneTransform- RewriteReturnM a ds (Count n) -> return $ RewriteReturnM a ds (Count $ succ n)- RewriteReturnM a ds (LoneTransform) -> return $ RewriteReturnM a ds (Count 2)- RewriteFailureM msg -> return $ RewriteFailureM msg- --- | 'transparently' sets the congruence flag, such that if the--- monadic action was identity preserving, then a 'markM' does--- not set the non-indentity flag.- -transparentlyM :: (Monad m) => RewriteM m dec a -> RewriteM m dec a-transparentlyM (RewriteM m) = RewriteM $ \ dec -> do- r <- m dec- case r of- RewriteReturnM a ds LoneTransform -> return $ RewriteReturnM a ds (Count 0)- RewriteReturnM a ds other -> return $ RewriteReturnM a ds other- RewriteFailureM msg -> return $ RewriteFailureM msg---- | 'getDecsM' reads the local environment-readEnvM :: (Monad m, Monoid dec) => RewriteM m dec dec-readEnvM = RewriteM $ \ dec -> return $ RewriteReturnM dec mempty mempty---- | 'mapDecs' changes the local environment, inside a local monadic invocation.-mapEnvM :: (Monad m, Monoid dec) => (dec -> dec) -> RewriteM m dec a -> RewriteM m dec a-mapEnvM fn (RewriteM m) = RewriteM $ \ dec -> m (fn dec)----- | 'writeDecM' writes a value to the writer monad inside the 'RewriteM'.-writeEnvM :: (Monad m,Monoid dec) => dec -> RewriteM m dec ()-writeEnvM dec = RewriteM $ \ _dec -> return $ RewriteReturnM () (Just dec) (Count 0)-
− Language/KURE/Term.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}---- | This module supports the generic walking of 'Term's. ------ The key idea here is that for each type of expression (@exp@), --- we have a sum of all the interesting children types (@Generic exp@).--- There is always a type that its own 'Generic', which is used for the --- deeper syntax tree walks.--module Language.KURE.Term - ( Term(..)- , Walker(..)- , extractR- , promoteR- , extractU- , promoteU- , topdownR- , bottomupR - , alltdR - , downupR - , innermostR - , foldU - ) where- -import Language.KURE.Translate -import Language.KURE.Rewrite-import Language.KURE.Combinators--import Control.Monad-import Data.Monoid---- | 'Term's are things that syntax are built from.-class Term exp where- -- | 'Generic' is a sum of all the interesting sub-types, transitively, of @exp@. - -- We use @Generic e ~ e@ to signify that something is its own Generic.- -- Simple expression types might be their own sole 'Generic', more complex examples- -- will have a new datatype for the 'Generic', which will also be an instance of class 'Term'.- type Generic exp-- -- | 'project' projects into a 'Generic', to get the exp inside, or fails.- select :: Generic exp -> Maybe exp-- -- | 'inject' injects an exp into a 'Generic'.- inject :: exp -> Generic exp----- | 'Walker' captures how we walk over @exp@, using a specific @m@ and @dec@.-class (Monoid dec,Monad m,Term exp) => Walker m dec exp where- -- | 'allR' applies 'Generic' rewrites to all the interesting children of this node.- allR :: Rewrite m dec (Generic exp) -> Rewrite m dec exp- -- | 'allU' applied a 'Generic' Translation to a common, 'Monoid'al result, to all the interesting children of this node.- crushU :: (Monoid result) => Translate m dec (Generic exp) result -> Translate m dec exp result------------------------------------------------------------------------------------ | 'extractR' converts a 'Rewrite' over a 'Generic' into a rewrite over a specific expression type. --extractR :: (Monad m, Term exp, Monoid dec) => Rewrite m dec (Generic exp) -> Rewrite m dec exp -- at *this* type-extractR rr = transparently $ rewrite $ \ e -> do- e' <- apply rr (inject e)- case select e' of- Nothing -> fail "extractR"- Just r -> return r- --- | 'extractU' converts a 'Translate' taking a 'Generic' into a translate over a specific expression type. --extractU :: (Monad m, Term exp, Monoid dec) => Translate m dec (Generic exp) r -> Translate m dec exp r-extractU rr = transparently $ translate $ \ e -> apply rr (inject e)---- | 'promoteR' promotes a 'Rewrite' into a 'Generic' 'Rewrite'; other types inside Generic cause failure.--- 'try' can be used to convert a failure-by-default promotion into a 'id-by-default' promotion.--promoteR :: (Monad m, Term exp, Monoid dec) => Rewrite m dec exp -> Rewrite m dec (Generic exp)-promoteR rr = transparently $ rewrite $ \ e -> do- case select e of- Nothing -> fail "promoteR"- Just e' -> do- r <- apply rr e'- return (inject r)---- | 'promoteU' promotes a 'Translate' into a 'Generic' 'Translate'; other types inside Generic cause failure.--promoteU :: (Monad m, Term exp, Monoid dec) => Translate m dec exp r -> Translate m dec (Generic exp) r-promoteU rr = transparently $ translate $ \ e -> do- case select e of- Nothing -> fail "promoteI"- Just e' -> apply rr e'------------------------------------------------------------------------------------- | apply a rewrite in a top down manner.-topdownR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-topdownR s = s >-> allR (topdownR s)---- | apply a rewrite in a bottom up manner.-bottomupR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-bottomupR s = allR (bottomupR s) >-> s---- | apply a rewrite in a top down manner, prunning at successful rewrites.-alltdR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-alltdR s = s <+ allR (alltdR s)---- | apply a rewrite twice, in a topdown and bottom up way, using one single tree traversal.-downupR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-downupR s = s >-> allR (downupR s) >-> s---- | a fixed point traveral, starting with the innermost term.-innermostR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-innermostR s = bottomupR (tryR (s >-> innermostR s)) ---- fold a tree using a single translation for each node.-foldU :: (e ~ Generic e, Walker m dec e, Monoid r) => Translate m dec (Generic e) r -> Translate m dec (Generic e) r-foldU s = concatT [ s, crushU (foldU s) ]---------------------------------------------------------------------------------
Language/KURE/Translate.hs view
@@ -1,70 +1,229 @@ -- |--- Module: Language.KURE.Translate --- Copyright: (c) 2006-2008 Andy Gill+-- Module: Language.KURE.Translate+-- Copyright: (c) 2012 The University of Kansas -- License: BSD3 ----- Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta -- Portability: ghc ----- 'Translate' is the main abstraction inside KURE, and represents a rewriting from a source to a target--- of a possibly different type.+-- This module defines the main KURE types: 'Translate', 'Rewrite' and 'Lens'.+-- 'Rewrite' and 'Lens' are just special cases of 'Translate', and so any function that operates on 'Translate' is also+-- applicable to 'Rewrite' and 'Lens' (although care should be taken in the 'Lens' case). ----- Rewrite (defined in 'Language.KURE.Rewrite') is a synonoym for a 'Translate' with the same source and target type.+-- This module also contains 'Translate' instance declarations for the 'Monad' and 'Arrow' type-class families.+-- Given these instances, many of the desirable combinators over 'Translate' and 'Rewrite' are special cases+-- of existing monadic or arrow combinators.+-- "Language.KURE.Combinators" provides some additional combinators that aren't in the standard libraries. -module Language.KURE.Translate - ( Translate- , apply- , runTranslate- , transparently- , translate- ) where- +module Language.KURE.Translate+ ( -- * Translations+ Translate(..)+ , Rewrite+ , translate+ , rewrite+ , contextfreeT+ , constT+ , contextT+ , exposeT+ , mapT+ -- * Lenses+ , Lens+ , lens+ , idL+ , tryL+ , composeL+ , sequenceL+ , pureL+ , focusR+ , focusT++) where++import Prelude hiding (id, (.))+import Control.Applicative import Control.Monad+import Control.Category+import Control.Arrow import Data.Monoid -import Language.KURE.RewriteMonad+------------------------------------------------------------------------------------------ --- | 'Translate' is a translation or strategy that translates between @exp1@ and @exp2@, with the posiblity of failure,--- and remembers identity translations.+-- | 'Translate' is a translation or strategy that translates from a value in a context to a monadic value.+data Translate c m a b = Translate { -- | Apply a 'Translate' to a value and its context.+ apply :: c -> a -> m b} -newtype Translate m dec exp1 exp2 =- Translate ( exp1 -> RewriteM m dec exp2 )+-- | A 'Rewrite' is a 'Translate' that shares the same source and target type.+type Rewrite c m a = Translate c m a a --- | 'apply' directly applies a 'Translate' value to an argument.-apply :: (Monoid dec, Monad m) => Translate m dec exp1 exp2 -> exp1 -> RewriteM m dec exp2-apply (Translate t) exp1 = t exp1 +-- | The primitive way of building a 'Translate'.+translate :: (c -> a -> m b) -> Translate c m a b+translate = Translate --- | 'translate' is the standard way of building a 'Translate', where if the translation is successful it --- is automatically marked as a non-identity translation. ------ Note: @translate $ \\ e -> return e@ /is not/ an identity rewrite, but a succesful rewrite that--- returns its provided argument. +-- | The primitive way of building a 'Rewrite'.+rewrite :: (c -> a -> m a) -> Rewrite c m a+rewrite = translate -translate :: (Monoid dec, Monad m) => (exp1 -> RewriteM m dec exp2) -> Translate m dec exp1 exp2-translate f = Translate $ \ e -> markM $ f e+------------------------------------------------------------------------------------------ +-- | Build a 'Translate' that doesn't depend on the context.+contextfreeT :: (a -> m b) -> Translate c m a b+contextfreeT = translate . const --- | 'transparently' marks a 'translate' (or 'rewrite') as transparent, that is the identity status--- of any internal applications of 'apply' is preserved across the translate.------ Note: @transparently $ translate $ \\ e -> return e@ /is/ an identity rewrite.+-- | Build a constant 'Translate' from a monadic computation.+constT :: m b -> Translate c m a b+constT = contextfreeT . const -transparently :: (Monoid dec, Monad m) => Translate m dec exp1 exp2 -> Translate m dec exp1 exp2-transparently (Translate m) = Translate $ \ e -> transparentlyM (m e)+-- | Extract the current context.+contextT :: Monad m => Translate c m a c+contextT = translate (\ c _ -> return c) --- | 'runTranslate' executes the translation, returning either a failure message,--- or a success and the new parts of the environment.+-- | Expose the current context and value.+exposeT :: Monad m => Translate c m a (c,a)+exposeT = translate (curry return) -runTranslate :: (Monoid dec,Monad m) - => Translate m dec exp res- -> dec - -> exp - -> m (Either String (res,dec,Int))-runTranslate rr dec e = do- res <- runRewriteM (apply rr e) dec- case res of- RewriteReturnM exp' Nothing c -> return (Right (exp',mempty,theCount c))- RewriteReturnM exp' (Just ds) c -> return (Right (exp',ds,theCount c))- RewriteFailureM msg -> return (Left msg)+-- | Map a 'Translate' over a list.+mapT :: Monad m => Translate c m a b -> Translate c m [a] [b]+mapT t = translate (mapM . apply t) +------------------------------------------------------------------------------------------++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Functor m => Functor (Translate c m a) where++-- fmap :: (b -> d) -> Translate c m a b -> Translate c m a d+ fmap f t = translate (\ c -> fmap f . apply t c)++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Applicative m => Applicative (Translate c m a) where++-- pure :: b -> Translate c m a b+ pure = constT . pure++-- (<*>) :: Translate c m a (b -> d) -> Translate c m a b -> Translate c m a d+ tf <*> tb = translate (\ c a -> apply tf c a <*> apply tb c a)++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Alternative m => Alternative (Translate c m a) where++-- empty :: Translate c m a b+ empty = constT empty++-- (<|>) :: Translate c m a b -> Translate c m a b -> Translate c m a b+ t1 <|> t2 = translate $ \ c a -> apply t1 c a <|> apply t2 c a++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Monad m => Monad (Translate c m a) where++-- return :: b -> Translate c m a b+ return = constT . return++-- (>>=) :: Translate c m a b -> (b -> Translate c m a d) -> Translate c m a d+ t >>= f = translate $ \ c a -> do b <- apply t c a+ apply (f b) c a++-- fail :: String -> Translate c m a b+ fail = constT . fail++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadPlus m => MonadPlus (Translate c m a) where++-- mzero :: Translate c m a b+ mzero = constT mzero++-- mplus :: Translate c m a b -> Translate c m a b -> Translate c m a b+ mplus t1 t2 = translate $ \ c a -> apply t1 c a `mplus` apply t2 c a++-- | The 'Kleisli' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => Category (Translate c m) where++-- id :: Translate c m a a+ id = contextfreeT return++-- (.) :: Translate c m b d -> Translate c m a b -> Translate c m a d+ t2 . t1 = translate $ \ c -> apply t1 c >=> apply t2 c++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => Arrow (Translate c m) where++-- arr :: (a -> b) -> Translate c m a b+ arr f = contextfreeT (return . f)++-- first :: (a -> b) -> Translate c m (a,z) (b,z)+ first t = translate $ \ c (a,z) -> liftM (\b -> (b,z)) (apply t c a)++-- (***) :: Translate c m a1 b1 -> Translate c m a2 b2 -> Translate c m (a1,a2) (b1,b2)+ t1 *** t2 = translate $ \ c (a,b) -> liftM2 (,) (apply t1 c a) (apply t2 c b)++-- (&&&) :: Translate c m a b1 -> Translate c m a b2 -> Translate c m a (b1,b2)+ t1 &&& t2 = translate $ \ c a -> liftM2 (,) (apply t1 c a) (apply t2 c a)++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance MonadPlus m => ArrowZero (Translate c m) where++-- zeroArrow :: Translate c m a b+ zeroArrow = mzero++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance MonadPlus m => ArrowPlus (Translate c m) where++-- (<+>) :: Translate c m a b -> Translate c m a b -> Translate c m a b+ (<+>) = mplus++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => ArrowApply (Translate c m) where++-- app :: Translate c m (Translate c m a b, a) b+ app = translate $ \ c (t,a) -> apply t c a++-- | Lifting through the 'Monad' and a Reader transformer, where (c,a) is the read-only environment.+instance (Monad m, Monoid b) => Monoid (Translate c m a b) where++-- mempty :: Translate c m a b+ mempty = return mempty++-- mappend :: Translate c m a b -> Translate c m a b -> Translate c m a b+ mappend = liftM2 mappend++------------------------------------------------------------------------------------------++-- | A 'Lens' is a way to focus in on a particular point in a structure.+type Lens c m a b = Translate c m a ((c,b), b -> m a)++-- | 'lens' is the primitive way of building a 'Lens'.+lens :: (c -> a -> m ((c,b), b -> m a)) -> Lens c m a b+lens = translate++-- | Identity 'Lens'.+idL :: Monad m => Lens c m a a+idL = lens $ \ c a -> return ((c,a), return)++-- | Catch a failing endo'Lens', making it into an identity.+tryL :: MonadPlus m => Lens c m a a -> Lens c m a a+tryL l = l <+> idL++-- | Composition of 'Lens's.+composeL :: Monad m => Lens c m a b -> Lens c m b d -> Lens c m a d+composeL l1 l2 = lens $ \ ca a -> do ((cb,b),kb) <- apply l1 ca a+ ((cd,d),kd) <- apply l2 cb b+ return ((cd,d),kd >=> kb)++-- | Sequence a list of endo'Lens's.+sequenceL :: MonadPlus m => [Lens c m a a] -> Lens c m a a+sequenceL = foldr composeL idL++-- | Construct a 'Lens' from two pure functions.+pureL :: Monad m => (a -> b) -> (b -> a) -> Lens c m a b+pureL f g = lens (\ c a -> return ((c,f a), return . g))++-- | Apply a 'Rewrite' at a point specified by a 'Lens'.+focusR :: Monad m => Lens c m a b -> Rewrite c m b -> Rewrite c m a+focusR l r = rewrite $ \ c a -> do ((c',b),k) <- apply l c a+ apply r c' b >>= k++-- | Apply a 'Translate' at a point specified by a 'Lens'.+focusT :: Monad m => Lens c m a b -> Translate c m b d -> Translate c m a d+focusT l t = translate $ \ c a -> do ((c',b),_) <- apply l c a+ apply t c' b++------------------------------------------------------------------------------------------
+ Language/KURE/Utilities.hs view
@@ -0,0 +1,176 @@+-- |+-- Module: Language.KURE.Utilities+-- Copyright: (c) 2012 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module contains several utility functions that can be useful to users of KURE,+-- when definining instances of the KURE classes.++module Language.KURE.Utilities+ ( -- * Generic Combinators+ -- $genericdoc+ allTgeneric+ , allRgeneric+ , anyRgeneric+ , childLgeneric+ -- * Attempt Combinators+ -- $attemptdoc+ , attemptAny2+ , attemptAny3+ , attemptAnyN+ , attemptAny1N+ -- * Error Messages+ , missingChildL+ -- * Child Combinators+ -- $childLdoc+ , childLaux+ , childL0of1+ , childL0of2+ , childL1of2+ , childL0of3+ , childL1of3+ , childL2of3+ , childL0of4+ , childL1of4+ , childL2of4+ , childL3of4+ , childLMofN+) where++import Control.Monad+import Control.Arrow++import Data.Monoid++import Language.KURE.Combinators+import Language.KURE.Translate+import Language.KURE.Walker+import Language.KURE.Injection++-------------------------------------------------------------------------------++-- $genericdoc+-- These functions are to aid with defining 'Walker' instances for the 'Generic' type.+-- See the \"Expr\" example.++allTgeneric :: (Walker c m a, Monoid b) => Translate c m (Generic a) b -> c -> a -> m b+allTgeneric t c a = inject `liftM` apply (allT t) c a++allRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a)+allRgeneric r c a = inject `liftM` apply (allR r) c a++anyRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a)+anyRgeneric r c a = inject `liftM` apply (anyR r) c a++childLgeneric :: Walker c m a => Int -> c -> a -> m ((c, Generic a), Generic a -> m (Generic a))+childLgeneric n c a = (liftM.second.result.liftM) inject $ apply (childL n) c a++-------------------------------------------------------------------------------++-- $attemptdoc+-- These are useful when defining congruence combinators that succeed if any child rewrite succeeds.+-- As well as being generally useful, such combinators are helpful when defining 'anyR' instances.+-- See the \"Lam\" or \"Expr\" examples, or the HERMIT package.++attemptAny2 :: Monad m => (a1 -> a2 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m r+attemptAny2 f mba1 mba2 = do (b1,a1) <- mba1+ (b2,a2) <- mba2+ if b1 || b2+ then return (f a1 a2)+ else fail "failed for both children."++attemptAny3 :: Monad m => (a1 -> a2 -> a3 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m (Bool,a3) -> m r+attemptAny3 f mba1 mba2 mba3 = do (b1,a1) <- mba1+ (b2,a2) <- mba2+ (b3,a3) <- mba3+ if b1 || b2 || b3+ then return (f a1 a2 a3)+ else fail "failed for all three children."++attemptAnyN :: Monad m => ([a] -> b) -> [m (Bool,a)] -> m b+attemptAnyN f mbas = do (bs,as) <- unzip `liftM` sequence mbas+ if or bs+ then return (f as)+ else fail ("failed for all " ++ show (length bs) ++ " children.")++attemptAny1N :: Monad m => (a1 -> [a2] -> r) -> m (Bool,a1) -> [m (Bool,a2)] -> m r+attemptAny1N f mba mbas = do (b ,a) <- mba+ (bs,as) <- unzip `liftM` sequence mbas+ if or (b:bs)+ then return (f a as)+ else fail ("failed for all " ++ show (1 + length bs) ++ " children.")++-------------------------------------------------------------------------------++-- | A failing 'Lens' with a standard error message for when the child index is out of bounds.++missingChildL :: Monad m => Int -> Lens c m a b+missingChildL n = fail ("There is no child number " ++ show n ++ ".")++-------------------------------------------------------------------------------++-- $childLdoc+-- These functions are helpful when defining 'childL' instances in combination with congruence combinators.+-- See the \"Lam\" and \"Expr\" examples, or the HERMIT package.+--+-- Unfortunately they increase quadratically with the number of fields of the constructor.+-- It would be nice if they were further expanded to include the calls of 'idR' and 'exposeT';+-- however this would create a plethora of additional cases as the number (and positions)+-- of interesting children would be additional dimensions.+--+-- Note that the numbering scheme MofN is that N is the number of children (including uninteresting children)+-- and M is the index of the chosen child, starting with index 0. Thus M ranges from 0 to (n-1).+--+-- TO DO: use Template Haskell to generate these.+--+-- In the mean time, if you need a few more than provided here, drop me an email and I'll add them.++childLaux :: (MonadPlus m, Term b) => (c,b) -> (b -> a) -> ((c, Generic b), Generic b -> m a)+childLaux cb g = (second inject cb, liftM (inject.g) . retractM)++childL0of1 :: (MonadPlus m, Term b) => (b -> a) -> (c,b) -> ((c, Generic b) , Generic b -> m a)+childL0of1 f cb = childLaux cb f++childL0of2 :: (MonadPlus m, Term b0) => (b0 -> b1 -> a) -> (c,b0) -> b1 -> ((c, Generic b0) , Generic b0 -> m a)+childL0of2 f cb0 b1 = childLaux cb0 (\ b0 -> f b0 b1)++childL1of2 :: (MonadPlus m, Term b1) => (b0 -> b1 -> a) -> b0 -> (c,b1) -> ((c, Generic b1) , Generic b1 -> m a)+childL1of2 f b0 cb1 = childLaux cb1 (\ b1 -> f b0 b1)++childL0of3 :: (MonadPlus m, Term b0) => (b0 -> b1 -> b2 -> a) -> (c,b0) -> b1 -> b2 -> ((c, Generic b0) , Generic b0 -> m a)+childL0of3 f cb0 b1 b2 = childLaux cb0 (\ b0 -> f b0 b1 b2)++childL1of3 :: (MonadPlus m, Term b1) => (b0 -> b1 -> b2 -> a) -> b0 -> (c,b1) -> b2 -> ((c, Generic b1) , Generic b1 -> m a)+childL1of3 f b0 cb1 b2 = childLaux cb1 (\ b1 -> f b0 b1 b2)++childL2of3 :: (MonadPlus m, Term b2) => (b0 -> b1 -> b2 -> a) -> b0 -> b1 -> (c,b2) -> ((c, Generic b2) , Generic b2 -> m a)+childL2of3 f b0 b1 cb2 = childLaux cb2 (\ b2 -> f b0 b1 b2)++childL0of4 :: (MonadPlus m, Term b0) => (b0 -> b1 -> b2 -> b3 -> a) -> (c,b0) -> b1 -> b2 -> b3 -> ((c, Generic b0) , Generic b0 -> m a)+childL0of4 f cb0 b1 b2 b3 = childLaux cb0 (\ b0 -> f b0 b1 b2 b3)++childL1of4 :: (MonadPlus m, Term b1) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> (c,b1) -> b2 -> b3 -> ((c, Generic b1) , Generic b1 -> m a)+childL1of4 f b0 cb1 b2 b3 = childLaux cb1 (\ b1 -> f b0 b1 b2 b3)++childL2of4 :: (MonadPlus m, Term b2) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> b1 -> (c,b2) -> b3 -> ((c, Generic b2) , Generic b2 -> m a)+childL2of4 f b0 b1 cb2 b3 = childLaux cb2 (\ b2 -> f b0 b1 b2 b3)++childL3of4 :: (MonadPlus m, Term b3) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> b1 -> b2 -> (c,b3) -> ((c, Generic b3) , Generic b3 -> m a)+childL3of4 f b0 b1 b2 cb3 = childLaux cb3 (\ b3 -> f b0 b1 b2 b3)++childLMofN :: (MonadPlus m, Term b) => Int -> ([b] -> a) -> [(c,b)] -> ((c, Generic b) , Generic b -> m a)+childLMofN m f cbs = childLaux (cbs !! m) (\ b' -> f $ atIndex m (const b') (map snd cbs))++-------------------------------------------------------------------------------++-- | Modify the value in a list at specified index.+atIndex :: Int -> (a -> a) -> [a] -> [a]+atIndex i f as = [ if n == i then f a else a+ | (a,n) <- zip as [0..]+ ]++-------------------------------------------------------------------------------
+ Language/KURE/Walker.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}++-- |+-- Module: Language.KURE.Walker+-- Copyright: (c) 2012 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides combinators that traverse a tree.+--+-- Note that all traversals take place on the node, its children, or its descendents.+-- There is no mechanism for \"ascending\" the tree.++module Language.KURE.Walker+ ( -- * Traversal Classes+ Term(..)+ , Walker(..)++ -- * Rewrite Traversals+ , childR+ , alltdR+ , anytdR+ , allbuR+ , anybuR+ , allduR+ , anyduR+ , tdpruneR+ , innermostR++ -- * Translate Traversals+ , childT+ , foldtdT+ , foldbuT+ , tdpruneT+ , crushtdT+ , crushbuT++ -- * Building Lenses+ , Path+ , pathL+ , exhaustPathL+ , repeatPathL+) where++import Data.Monoid+import Control.Monad+import Control.Arrow++import Language.KURE.Combinators+import Language.KURE.Translate+import Language.KURE.Injection++------------------------------------------------------------------------------------------++-- | A 'Term' is any node in the tree that you wish to be able to traverse.++class (Injection a (Generic a), Generic a ~ Generic (Generic a)) => Term a where++ -- | 'Generic' is a sum of all the interesting sub-types, transitively, of @a@.+ -- We use @Generic a ~ a@ to signify that something is its own Generic.+ -- Simple expression types might be their own sole 'Generic', more complex examples+ -- will have a new datatype for the 'Generic', which will also be an instance of class 'Term'.+ type Generic a :: *++ -- | Count the number of interesting children.+ numChildren :: a -> Int++-------------------------------------------------------------------------------++-- | 'Walker' captures the ability to walk over a 'Term' applying 'Rewrite's,+-- using a specific context @c@ and a 'MonadPlus' @m@.+--+-- Minimal complete definition: 'childL'.+--+-- Default instances are provided for 'allT', 'allR' and 'anyR', but they may be overridden for efficiency.+-- For small numbers of interesting children this will not be an issue, but for a large number, say+-- for a list of children, it may be.++class (MonadPlus m, Term a) => Walker c m a where++ -- | Construct a 'Lens' pointing at the n-th interesting child of this node.+ childL :: Int -> Lens c m a (Generic a)++ -- | Apply a 'Generic' 'Translate' to all interesting children of this node, succeeding if they all succeed.+ -- The results are combined in a 'Monoid'.+ allT :: Monoid b => Translate c m (Generic a) b -> Translate c m a b+ allT t = do n <- arr numChildren+ mconcat [ childT i t | i <- [0..(n-1)] ]++ -- | Apply a 'Generic' 'Rewrite' to all interesting children of this node, succeeding if they all succeed.+ allR :: Rewrite c m (Generic a) -> Rewrite c m a+ allR r = do n <- arr numChildren+ andR [ childR i r | i <- [0..(n-1)] ]++ -- | Apply 'Generic' 'Rewrite' to all interesting children of this node, suceeding if any succeed.+ anyR :: Rewrite c m (Generic a) -> Rewrite c m a+ anyR r = do n <- arr numChildren+ orR [ childR i r | i <- [0..(n-1)] ]++-- | Apply a 'Translate' to a specific child.+childT :: Walker c m a => Int -> Translate c m (Generic a) b -> Translate c m a b+childT n = focusT (childL n)++-- | Apply a 'Rewrite' to a specific child.+childR :: Walker c m a => Int -> Rewrite c m (Generic a) -> Rewrite c m a+childR n = focusR (childL n)++-------------------------------------------------------------------------------++-- | Fold a tree in a top-down manner, using a single 'Translate' for each node.+foldtdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+foldtdT t = t `mappend` allT (foldtdT t)++-- | Fold a tree in a bottom-up manner, using a single 'Translate' for each node.+foldbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+foldbuT t = allT (foldbuT t) `mappend` t++-- | Attempt to apply a 'Translate' in a top-down manner, prunning at successes.+tdpruneT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+tdpruneT t = t <+> allT (tdpruneT t)++-- | An always successful top-down fold, replacing failures with 'mempty'.+crushtdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+crushtdT t = foldtdT (mtryM t)++-- | An always successful bottom-up fold, replacing failures with 'mempty'.+crushbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+crushbuT t = foldbuT (mtryM t)++-------------------------------------------------------------------------------++-- | Apply a 'Rewrite' in a top-down manner, succeeding if they all succeed.+alltdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+alltdR r = r >>> allR (alltdR r)++-- | Apply a 'Rewrite' in a top-down manner, succeeding if any succeed.+anytdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+anytdR r = r >+> anyR (anytdR r)++-- | Apply a 'Rewrite' in a bottom-up manner, succeeding if they all succeed.+allbuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+allbuR r = allR (allbuR r) >>> r++-- | Apply a 'Rewrite' in a bottom-up manner, succeeding if any succeed.+anybuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+anybuR r = anyR (anybuR r) >+> r++-- | Apply a 'Rewrite' twice, in a top-down and bottom-up way, using one single tree traversal,+-- succeeding if they all succeed.+allduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+allduR r = r >>> allR (allduR r) >>> r++-- | Apply a 'Rewrite' twice, in a top-down and bottom-up way, using one single tree traversal,+-- succeeding if any succeed.+anyduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+anyduR r = r >+> anyR (anyduR r) >+> r++-- | Attempt to apply a 'Rewrite' in a top-down manner, prunning at successful rewrites.+tdpruneR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+tdpruneR r = r <+> anyR (tdpruneR r)++-- | A fixed-point traveral, starting with the innermost term.+innermostR :: (Walker c m a, Generic a ~ a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+innermostR r = anybuR (r >>> tryR (innermostR r))++-------------------------------------------------------------------------------++-- | A 'Path' is a list of 'Int's, where each 'Int' specifies which interesting child to descend to at each step.+type Path = [Int]++-- | Construct a 'Lens' by following a 'Path'.+pathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)+pathL = sequenceL . map childL++-- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed.+exhaustPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)+exhaustPathL [] = idL+exhaustPathL (n:ns) = tryL (childL n `composeL` exhaustPathL ns)++-- | Repeat as many iterations of the 'Path' as possible.+repeatPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)+repeatPathL p = tryL (pathL p `composeL` repeatPathL p)++-------------------------------------------------------------------------------
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,2 @@+> import Distribution.Simple+> main = defaultMain
+ examples/Examples.hs view
@@ -0,0 +1,21 @@+module Examples where++import Fib.Examples as F+import Lam.Examples as L+import Expr.Examples as E++---------------------------------------------------------------++main :: IO ()+main = do ppTest "Fib" F.checkTests+ ppTest "Lam" L.checkTests+ ppTest "Expr" E.checkTests++ppTest :: String -> Bool -> IO ()+ppTest n b = putStrLn (n ++ " examples: tests " ++ ppBool b)++ppBool :: Bool -> String+ppBool True = "passed"+ppBool False = "failed"++---------------------------------------------------------------
+ examples/Expr/AST.hs view
@@ -0,0 +1,31 @@+module Expr.AST where++-----------------------------------------------------------------++type Name = String++data Cmd = Seq Cmd Cmd | Assign Name Expr+ deriving Eq++data Expr = Var Name | Lit Int | Add Expr Expr | ESeq Cmd Expr+ deriving Eq++instance Show Cmd where+ show (Seq c1 c2) = show c1 ++ " ; " ++ show c2+ show (Assign n e) = n ++ " := " ++ show e++instance Show Expr where+ show (Var n) = n+ show (Lit n) = show n+ show (Add e1 e2) = "(" ++ show e1 ++ " + " ++ show e2 ++ ")"+ show (ESeq c e) = "\n( let " ++ show c ++ "\n in " ++ show e ++ ")\n"++-----------------------------------------------------------------++type Context = [(Name,Expr)]++updateContext :: Cmd -> Context -> Context+updateContext (Seq c1 c2) = updateContext c2 . updateContext c1+updateContext (Assign v e) = ((v,e):)++-----------------------------------------------------------------
+ examples/Expr/Examples.hs view
@@ -0,0 +1,75 @@+module Expr.Examples where++import Language.KURE+import Language.KURE.Injection++import Expr.AST+import Expr.Kure++-----------------------------------------------------------------++inlineR :: RewriteE Expr+inlineR = do (c, Var v) <- exposeT+ constT (lookup v c)++inlineGR :: RewriteE GenericExpr+inlineGR = promoteR inlineR++-----------------------------------------------------------------++expr1 :: Expr+expr1 = ESeq (Seq (Assign "m" (Lit 7))+ (Assign "n" (Add (Lit 1) (Lit 2)))+ )+ (Add (Var "m")+ (Var "n")+ )++result1 :: Expr+result1 = ESeq (Seq (Assign "m" (Lit 7))+ (Assign "n" (Add (Lit 1) (Lit 2)))+ )+ (Add (Lit 7)+ (Add (Lit 1) (Lit 2))+ )++test1 :: Bool+test1 = apply (extractR (anytdR inlineGR)) [] expr1 == Just result1++expr2 :: Expr+expr2 = ESeq (Seq (Assign "m" (Lit 7))+ (Assign "n" (Add (Lit 1) (Lit 2)))+ )+ (Add (Var "m")+ (Var "x")+ )++result2 :: Expr+result2 = ESeq (Seq (Assign "m" (Lit 7))+ (Assign "n" (Add (Lit 1) (Lit 2)))+ )+ (Add (Lit 7)+ (Var "x")+ )+test2 :: Bool+test2 = apply (extractR (anytdR inlineGR)) [] expr2 == Just result2++expr3 :: Expr+expr3 = ESeq (Assign "m" (Lit 7)+ )+ (Add (Var "y")+ (Var "x")+ )++test3 :: Bool+test3 = apply (extractR (anytdR inlineGR)) [] expr3 == Nothing++-----------------------------------------------------------------++checkTests :: Bool+checkTests = and [ test1+ , test2+ , test3+ ]++-----------------------------------------------------------------
+ examples/Expr/Kure.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}++module Expr.Kure where++import Control.Applicative++import Data.Monoid++import Language.KURE+import Language.KURE.Injection+import Language.KURE.Utilities++import Expr.AST++---------------------------------------------------------------------------++-- NOTE: allT, allR and anyR have been defined to serve as examples,+-- but using the default instances would be fine (just slightly less efficient).++---------------------------------------------------------------------------++type TranslateE a b = Translate Context Maybe a b+type RewriteE a = TranslateE a a++---------------------------------------------------------------------------++data GenericExpr = GExpr Expr+ | GCmd Cmd++instance Term GenericExpr where+ type Generic GenericExpr = GenericExpr++ numChildren (GExpr e) = numChildren e+ numChildren (GCmd c) = numChildren c++---------------------------------------------------------------------------++instance Walker Context Maybe GenericExpr where++ childL n = lens $ \ c g -> case g of+ GExpr e -> childLgeneric n c e+ GCmd cm -> childLgeneric n c cm++ allT t = translate $ \ c g -> case g of+ GExpr e -> allTgeneric t c e+ GCmd cm -> allTgeneric t c cm++ allR r = rewrite $ \ c g -> case g of+ GExpr e -> allRgeneric r c e+ GCmd cm -> allRgeneric r c cm++ anyR r = rewrite $ \ c g -> case g of+ GExpr e -> anyRgeneric r c e+ GCmd cm -> anyRgeneric r c cm++---------------------------------------------------------------------------++instance Injection Expr GenericExpr where+ inject = GExpr++ retract (GExpr e) = Just e+ retract _ = Nothing++instance Term Expr where+ type Generic Expr = GenericExpr++ numChildren (Add _ _) = 2+ numChildren (ESeq _ _) = 2+ numChildren (Var _) = 0+ numChildren (Lit _) = 0+++instance Walker Context Maybe Expr where+ childL 0 = addT exposeT idR (childL0of2 Add)+ <+ eseqT exposeT idR (childL0of2 ESeq)+ <+ missingChildL 0+ childL 1 = addT idR exposeT (childL1of2 Add)+ <+ eseqT idR exposeT (childL1of2 ESeq)+ <+ missingChildL 1+ childL n = missingChildL n++ allT t = varT (\ _ -> mempty)+ <+ litT (\ _ -> mempty)+ <+ addT (extractT t) (extractT t) mappend+ <+ eseqT (extractT t) (extractT t) mappend+ <+ fail "allT failed"++ allR r = varT Var+ <+ litT Lit+ <+ addAllR (extractR r) (extractR r)+ <+ eseqAllR (extractR r) (extractR r)+ <+ fail "allR failed"++ anyR r = addAnyR (extractR r) (extractR r)+ <+ eseqAnyR (extractR r) (extractR r)+ <+ fail "anyR failed"++---------------------------------------------------------------------------++instance Injection Cmd GenericExpr where+ inject = GCmd++ retract (GCmd c) = Just c+ retract _ = Nothing++instance Term Cmd where+ type Generic Cmd = GenericExpr++ numChildren (Seq _ _) = 2+ numChildren (Assign _ _) = 2++instance Walker Context Maybe Cmd where++ childL 0 = seqT exposeT idR (childL0of2 Seq)+ <+ assignT exposeT (childL1of2 Assign)+ childL 1 = seqT idR exposeT (childL1of2 Seq)+ <+ missingChildL 1+ childL n = missingChildL n++ allT t = seqT (extractT t) (extractT t) mappend+ <+ assignT (extractT t) (\ _ -> id)++ allR r = seqAllR (extractR r) (extractR r)+ <+ assignR (extractR r)++ anyR r = seqAnyR (extractR r) (extractR r)+ <+ assignR (extractR r)+ <+ fail "anyR failed"++---------------------------------------------------------------------------++seqT' :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Cmd b+seqT' t1 t2 f = translate $ \ c cm -> case cm of+ Seq cm1 cm2 -> f (apply t1 c cm1) (apply t2 (updateContext cm1 c) cm2)+ _ -> fail "not a Seq"++seqT :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (a1 -> a2 -> b) -> TranslateE Cmd b+seqT t1 t2 f = seqT' t1 t2 (liftA2 f)++seqAllR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd+seqAllR r1 r2 = seqT r1 r2 Seq++seqAnyR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd+seqAnyR r1 r2 = seqT' (attemptR r1) (attemptR r2) (attemptAny2 Seq)++---------------------------------------------------------------------------++assignT :: TranslateE Expr a -> (Name -> a -> b) -> TranslateE Cmd b+assignT t f = translate $ \ c cm -> case cm of+ Assign n e -> f n <$> apply t c e+ _ -> fail "not an Assign"++assignR :: RewriteE Expr -> RewriteE Cmd+assignR r = assignT r Assign++---------------------------------------------------------------------------++varT :: (Name -> b) -> TranslateE Expr b+varT f = contextfreeT $ \ e -> case e of+ Var v -> pure (f v)+ _ -> fail "not a Var"++---------------------------------------------------------------------------++litT :: (Int -> b) -> TranslateE Expr b+litT f = contextfreeT $ \ e -> case e of+ Lit v -> pure (f v)+ _ -> fail "not a Lit"++---------------------------------------------------------------------------++addT' :: TranslateE Expr a1 -> TranslateE Expr a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Expr b+addT' t1 t2 f = translate $ \ c e -> case e of+ Add e1 e2 -> f (apply t1 c e1) (apply t2 c e2)+ _ -> fail "not an Add"++addT :: TranslateE Expr a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b+addT t1 t2 f = addT' t1 t2 (liftA2 f)++addAllR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr+addAllR r1 r2 = addT r1 r2 Add++addAnyR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr+addAnyR r1 r2 = addT' (attemptR r1) (attemptR r2) (attemptAny2 Add)++---------------------------------------------------------------------------++eseqT' :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Expr b+eseqT' t1 t2 f = translate $ \ c e -> case e of+ ESeq cm e1 -> f (apply t1 c cm) (apply t2 (updateContext cm c) e1)+ _ -> fail "not an ESeq"++eseqT :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b+eseqT t1 t2 f = eseqT' t1 t2 (liftA2 f)++eseqAllR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr+eseqAllR r1 r2 = eseqT r1 r2 ESeq++eseqAnyR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr+eseqAnyR r1 r2 = eseqT' (attemptR r1) (attemptR r2) (attemptAny2 ESeq)++---------------------------------------------------------------------------
+ examples/Fib/AST.hs view
@@ -0,0 +1,18 @@+module Fib.AST where++data Arith = Lit Int | Add Arith Arith | Sub Arith Arith | Fib Arith deriving Eq++instance Show Arith where+ show (Lit n) = show n+ show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"+ show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"+ show (Fib x) = "(Fib " ++ show x ++ ")"++instance Num Arith where+ (+) = Add+ (-) = Sub+ fromInteger = Lit . fromInteger+ negate x = Sub 0 x+ (*) = error "Multiplication not defined for Arith"+ abs = error "Absolute value not defined for Arith"+ signum = error "Signum not defined for Arith"
+ examples/Fib/Examples.hs view
@@ -0,0 +1,122 @@+module Fib.Examples where++import Language.KURE++import Fib.AST+import Fib.Kure++-----------------------------------------------------------------------++applyFib :: RewriteA -> Arith -> Maybe Arith+applyFib e = apply e ()++-----------------------------------------------------------------------++-- | Apply the definition of the fibonacci function once.+-- Requires the argument to Fib to be a Literal.+fibLitR :: RewriteA+fibLitR = do Fib (Lit n) <- idR+ case n of+ 0 -> return (Lit 0)+ 1 -> return (Lit 1)+ _ -> return (Add (Fib (Sub (Lit n) (Lit 1)))+ (Fib (Sub (Lit n) (Lit 2)))+ )++-- | Compute the addition of two literals.+addLitR :: RewriteA+addLitR = do Add (Lit m) (Lit n) <- idR+ return (Lit (m + n))++-- | Compute the subtraction of two literals.+subLitR :: RewriteA+subLitR = do Sub (Lit m) (Lit n) <- idR+ return (Lit (m - n))++-----------------------------------------------------------------------++arithR :: RewriteA+arithR = addLitR >+> subLitR++anyAddR :: RewriteA+anyAddR = anybuR addLitR++anySubR :: RewriteA+anySubR = anybuR subLitR++anyArithR :: RewriteA+anyArithR = anybuR arithR++evalR :: RewriteA+evalR = innermostR (arithR >+> fibLitR)++-----------------------------------------------------------------------++expr1 :: Arith+expr1 = (3 + 7) - (4 + 1)++expr2 :: Arith+expr2 = Fib 8++expr3 :: Arith+expr3 = 100 - Fib (3 + 7)++test1a :: Bool+test1a = applyFib anyAddR expr1+ ==+ Just (10 - 5)++test1b :: Bool+test1b = applyFib anySubR expr1+ ==+ Nothing++test1c :: Bool+test1c = applyFib anyArithR expr1+ ==+ Just 5++test1d :: Bool+test1d = applyFib evalR expr1+ ==+ Just 5++test2a :: Bool+test2a = applyFib fibLitR expr2+ ==+ Just ((Fib (8 - 1)) + (Fib (8 - 2)))++test2b :: Bool+test2b = applyFib (anytdR fibLitR) expr2+ ==+ Just ((Fib (8 - 1)) + (Fib (8 - 2)))++test2c :: Bool+test2c = applyFib evalR expr2+ ==+ Just 21++test3a :: Bool+test3a = applyFib anyArithR expr3+ ==+ Just (100 - (Fib 10))++test3b :: Bool+test3b = applyFib (anyArithR >+> anyR fibLitR) expr3+ ==+ Just (100 - ((Fib (10 - 1)) + (Fib (10 - 2))))++test3c :: Bool+test3c = applyFib evalR expr3+ ==+ Just 45++-----------------------------------------------------------------------++checkTests :: Bool+checkTests = and [ test1a, test1b, test1c, test1d+ , test2a, test2b, test2c, test3a+ , test3b, test3c+ ]++-----------------------------------------------------------------------
+ examples/Fib/Kure.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}++module Fib.Kure where++import Control.Applicative++import Language.KURE+import Fib.AST++--------------------------------------------------------------------------------------++-- | For this simple example, the context is always empty and 'Translate' always operates on 'Arith'+type TranslateA b = Translate () Maybe Arith b+type RewriteA = TranslateA Arith++--------------------------------------------------------------------------------------++instance Term Arith where+ type Generic Arith = Arith++ numChildren (Lit _) = 0+ numChildren (Add _ _) = 2+ numChildren (Sub _ _) = 2+ numChildren (Fib _) = 1++instance Walker () Maybe Arith where++ childL n = lens $ \ c e -> case e of+ Lit _ -> empty+ Add e1 e2 -> case n of+ 0 -> pure ((c,e1), \ e1' -> pure (Add e1' e2))+ 1 -> pure ((c,e2), \ e2' -> pure (Add e1 e2'))+ _ -> empty+ Sub e1 e2 -> case n of+ 0 -> pure ((c,e1), \ e1' -> pure (Sub e1' e2))+ 1 -> pure ((c,e2), \ e2' -> pure (Sub e1 e2'))+ _ -> empty+ Fib e1 -> case n of+ 0 -> pure ((c,e1), \ e1' -> pure (Fib e1'))+ _ -> empty++--------------------------------------------------------------------------------------
+ examples/Lam/AST.hs view
@@ -0,0 +1,67 @@+module Lam.AST where++import Control.Applicative+import Control.Monad++-------------------------------------------------------------------------------++import Control.Arrow (second)+import Language.KURE.Combinators (result)++type Name = String++data Exp = Lam Name Exp+ | App Exp Exp+ | Var Name+ deriving Eq++instance Show Exp where+ show (Var v) = v+ show (App x y) = "(" ++ show x ++ " " ++ show y ++ ")"+ show (Lam n x) = "(\\" ++ n ++ ". " ++ show x ++ ")"++-------------------------------------------------------------------------------++type Context = [Name] -- bound variable names++newtype LamM a = LamM {expM :: Int -> (Int, Either String a)}++runLamM :: LamM a -> Either String a+runLamM m = snd (expM m 0)++instance Functor LamM where+ fmap f (LamM m) = LamM ((result.second.fmap) f m)++instance Monad LamM where+ return a = LamM (\n -> (n,Right a))+ (LamM f) >>= gg = LamM $ \ n -> case f n of+ (n', Left msg) -> (n', Left msg)+ (n', Right a) -> expM (gg a) n'+ fail msg = LamM (\ n -> (n, Left msg))++instance MonadPlus LamM where+ mzero = fail ""+ (LamM f) `mplus` (LamM g) = LamM $ \ n -> case f n of+ (n', Left _) -> g n'+ (n', Right a) -> (n', Right a)++instance Applicative LamM where+ pure = return+ (<*>) = ap++instance Alternative LamM where+ empty = mzero+ (<|>) = mplus++-------------------------------------------------------------------------------++suggestName :: LamM Name+suggestName = LamM (\n -> ((n+1), Right (show n)))++freshName :: Context -> LamM Name+freshName c = do n <- suggestName+ if n `elem` c+ then freshName c+ else return n++-------------------------------------------------------------------------------
+ examples/Lam/Examples.hs view
@@ -0,0 +1,216 @@+module Lam.Examples where++import Language.KURE++import Lam.AST+import Lam.Kure++import Data.List (nub)+import Control.Monad (guard)+import Control.Arrow++------------------------------------------------------------------------++freeVarsT :: TranslateExp [Name]+freeVarsT = fmap nub $ crushbuT $ do (c, Var v) <- exposeT+ guard (v `notElem` c)+ return [v]++freeVars :: Exp -> [Name]+freeVars = either error id . applyExp freeVarsT++-- Only works for lambdas, fails for all others+alphaLam :: [Name] -> RewriteExp+alphaLam frees = do Lam v e <- idR+ v' <- constT $ freshName $ frees ++ v : freeVars e+ lamT (tryR $ substExp v (Var v')) (\ _ -> Lam v')++substExp :: Name -> Exp -> RewriteExp+substExp v s = rules_var <+ rules_lam <+ rule_app+ where+ -- From Lambda Calc Textbook, the 6 rules.+ rules_var = whenM (varT (==v)) (return s) -- Rule 1++ rules_lam = do Lam n e <- idR+ guard (n /= v) -- Rule 3+ guard (v `elem` freeVars e) -- Rule 4a+ if n `elem` freeVars s+ then alphaLam (freeVars s) >>> rules_lam -- Rule 5+ else lamR (substExp v s) -- Rule 4b++ rule_app = do App _ _ <- idR+ anyR (substExp v s) -- Rule 6++------------------------------------------------------------------------++beta_reduce :: RewriteExp+beta_reduce = do App (Lam v _) e2 <- idR+ focusT (pathL [0,0]) (tryR $ substExp v e2)++eta_expand :: RewriteExp+eta_expand = rewrite $ \ c f -> do v <- freshName c+ return $ Lam v (App f (Var v))++eta_reduce :: RewriteExp+eta_reduce = contextfreeT $ \ e -> case e of+ Lam v1 (App f (Var v2)) -> do guardFail (v1 == v2) $ "Cannot eta-reduce, " ++ v1 ++ " /= " ++ v2+ return f+ _ -> fail "Cannot eta-reduce, not lambda-app-var."++-- This might not actually be normal order evaluation+-- Contact the KURE maintainer if you can correct this definition.+normal_order_eval :: RewriteExp+normal_order_eval = anytdR (repeatR beta_reduce)++-- This might not actually be applicative order evaluation+-- Contact the KURE maintainer if you can correct this definition.+applicative_order_eval :: RewriteExp+applicative_order_eval = innermostR beta_reduce++------------------------------------------------------------------------++type LamTest = (RewriteExp,String,Exp,Maybe Exp)++runLamTest :: LamTest -> (Bool, String)+runLamTest (r,_,e,me) = case (applyExp r e , me) of+ (Right r1 , Just r2) | r1 == r2 -> (True, show r1)+ (Left msg , Nothing) -> (True, msg)+ (Left msg , Just _) -> (False, msg)+ (Right r1 , _ ) -> (False, show r1)++ppLamTest :: LamTest -> IO ()+ppLamTest t@(_,n,e,me) = do putStrLn $ "Rewrite: " ++ n+ putStrLn $ "Initial expression: " ++ show e+ putStrLn $ "Expected outcome: " ++ maybe "failure" show me+ let (b,msg) = runLamTest t+ putStrLn $ "Actual outcome: " ++ msg+ putStrLn (if b then "TEST PASSED" else "TEST FAILED")+ putStrLn ""++------------------------------------------------------------------------++x :: Exp+x = Var "x"++y :: Exp+y = Var "y"++z :: Exp+z = Var "z"++g :: Exp+g = Var "g"++h :: Exp+h = Var "h"++gx :: Exp+gx = App g x++gy :: Exp+gy = App g y++gz :: Exp+gz = App g z++hz :: Exp+hz = App h z++g0 :: Exp+g0 = App g (Var "0")++xx :: Exp+xx = App x x++yy :: Exp+yy = App y y++xz :: Exp+xz = App x z++fix :: Exp+fix = Lam "g" (App body body)+ where+ body = Lam "x" (App g xx)++------------------------------------------------------------------------++test_eta_exp1 :: LamTest+test_eta_exp1 = (eta_expand, "eta-expand", g, Just (Lam "0" g0))++test_eta_exp2 :: LamTest+test_eta_exp2 = (eta_expand, "eta-expand", App (Lam "g" gx) (Lam "y" yy), Just (Lam "0" (App (App (Lam "g" gx) (Lam "y" yy)) (Var "0"))))++test_eta_red1 :: LamTest+test_eta_red1 = (eta_reduce, "eta-reduce", Lam "x" gx , Just g)++test_eta_red2 :: LamTest+test_eta_red2 = (eta_reduce, "eta-reduce", Lam "x" gy, Nothing)++test_eta_red3 :: LamTest+test_eta_red3 = (eta_reduce, "eta-reduce", g, Nothing)++test_beta_red1 :: LamTest+test_beta_red1 = (beta_reduce, "beta-reduce", App (Lam "x" gx) z, Just gz)++test_beta_red2 :: LamTest+test_beta_red2 = (beta_reduce, "beta-reduce", App (Lam "x" gy) z, Just gy)++test_beta_red3 :: LamTest+test_beta_red3 = (beta_reduce, "beta-reduce", App x (Lam "y" gy), Nothing)++test_beta_reds1 :: LamTest+test_beta_reds1 = (anybuR beta_reduce, "any bottom-up beta-reduce", gx, Nothing)++test_beta_reds2 :: LamTest+test_beta_reds2 = (anybuR beta_reduce, "any bottom-up beta-reduce", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just (App (Lam "h" hz) x))++test_beta_reds3a :: LamTest+test_beta_reds3a = (beta_reduce, "beta-reduce", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just (App (Lam "h" (App h (App (Lam "y" y) z))) x))++test_beta_reds3 :: LamTest+test_beta_reds3 = (normal_order_eval, "normal order evaluation", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just xz)++test_beta_reds4 :: LamTest+test_beta_reds4 = (applicative_order_eval, "applicative order evaluation", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just xz)++test_fix1 :: LamTest+test_fix1 = (normal_order_eval, "normal order evaluation", App fix (Lam "_" x), Just x)++diverge :: Either String Exp+diverge = applyExp applicative_order_eval (App fix (Lam "_" x))++test_fix2 :: LamTest+test_fix2 = (anybuR (andR $ replicate 3 $ anybuR beta_reduce), "applicative order evaluation - 3 step cap", App fix (Lam "_" x)+ , Just (App (Lam "g" (App g (App g (App g (App g (App g (App g (App (Lam "x" (App g xx)) (Lam "x" (App g xx))))))))))+ (Lam "_" x))+ )++all_tests :: [LamTest]+all_tests = [ test_eta_exp1+ , test_eta_exp2+ , test_eta_red1+ , test_eta_red2+ , test_eta_red3+ , test_beta_red1+ , test_beta_red2+ , test_beta_red3+ , test_beta_reds1+ , test_beta_reds2+ , test_beta_reds3+ , test_beta_reds4+ , test_fix1+ , test_fix2+ ]++checkTests :: Bool+checkTests = all (fst . runLamTest) all_tests++printTests :: IO ()+printTests = mapM_ ppLamTest all_tests++------------------------------------------------------------------------
+ examples/Lam/Kure.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}++module Lam.Kure where++import Control.Applicative++import Language.KURE+import Language.KURE.Utilities++import Lam.AST++-------------------------------------------------------------------------------++type TranslateExp b = Translate Context LamM Exp b+type RewriteExp = TranslateExp Exp++applyExp :: TranslateExp b -> Exp -> Either String b+applyExp f = runLamM . apply f []++-------------------------------------------------------------------------------++instance Term Exp where+ type Generic Exp = Exp -- Exp is its own Generic++ numChildren (Var _) = 0+ numChildren (Lam _ _) = 1+ numChildren (App _ _) = 2++instance Walker Context LamM Exp where+ childL n = case n of+ 0 -> appT exposeT idR (childL0of2 App)+ <+ lamT exposeT (childL1of2 Lam)++ 1 -> appT idR exposeT (childL1of2 App)++ _ -> missingChildL n++-------------------------------------------------------------------------------++-- | Congruence combinators.+-- Using these ensures that the context is updated consistantly.++varT :: (Name -> b) -> TranslateExp b+varT f = contextfreeT $ \ e -> case e of+ Var n -> return (f n)+ _ -> fail "no match for Var"++-------------------------------------------------------------------------------++lamT :: TranslateExp a -> (Name -> a -> b) -> TranslateExp b+lamT t f = translate $ \ c e -> case e of+ Lam v e1 -> f v <$> apply t (v:c) e1+ _ -> fail "no match for Lam"++lamR :: RewriteExp -> RewriteExp+lamR r = lamT r Lam++-------------------------------------------------------------------------------++appT' :: TranslateExp a1 -> TranslateExp a2 -> (LamM a1 -> LamM a2 -> LamM b) -> TranslateExp b+appT' t1 t2 f = translate $ \ c e -> case e of+ App e1 e2 -> f (apply t1 c e1) (apply t2 c e2)+ _ -> fail "no match for App"++appT :: TranslateExp a1 -> TranslateExp a2 -> (a1 -> a2 -> b) -> TranslateExp b+appT t1 t2 f = appT' t1 t2 (liftA2 f)++appAllR :: RewriteExp -> RewriteExp -> RewriteExp+appAllR r1 r2 = appT r1 r2 App++appAnyR :: RewriteExp -> RewriteExp -> RewriteExp+appAnyR r1 r2 = appT' (attemptR r1) (attemptR r2) (attemptAny2 App)++-------------------------------------------------------------------------------
kure.cabal view
@@ -1,31 +1,49 @@ Name: kure-Version: 0.3.1+Version: 2.0.0 Synopsis: Combinators for Strategic Programming-Description: KURE is a DSL for building rewriting DSLs.- KURE shares combinator names and concepts with Stratego, but unlike Stratego, KURE is strongly typed.- KURE is similar to Strafunski, but has a lightweight generic traversal mechanism using type families- rather than SYB,- and the KURE combinators are parameterized to provide the ability to have context sensitive rewrites.+Description: The Kansas University Rewrite Engine (KURE) is a DSL for strategic rewriting.+ KURE shares concepts with Stratego, but unlike Stratego, KURE is strongly typed.+ KURE is similar to StrategyLib, but has a lightweight generic traversal mechanism using type families+ rather than SYB.+ The basic transformation functionality can be found in "Language.KURE.Translate",+ and the traversal functionality can be found in "Language.KURE.Walker".+ Several basic examples of using KURE are provided in the source-code bundle.+ For a larger example, see the HERMIT package. Category: Language License: BSD3 License-file: LICENSE-Author: Andy Gill-Maintainer: Andy Gill <andygill@ku.edu>-Copyright: (c) 2006-2009 Andy Gill-Homepage: http://ittc.ku.edu/~andygill/kure.php-Stability: alpha+Author: Neil Sculthorpe and Andy Gill+Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+Copyright: (c) 2012 The University of Kansas+Homepage: http://www.ittc.ku.edu/csdl/fpg/Tools/KURE+Stability: beta build-type: Simple Cabal-Version: >= 1.6+Extra-Source-Files:+ examples/Examples.hs+ examples/Fib/AST.hs+ examples/Fib/Kure.hs+ examples/Fib/Examples.hs+ examples/Lam/AST.hs+ examples/Lam/Kure.hs+ examples/Lam/Examples.hs+ examples/Expr/AST.hs+ examples/Expr/Kure.hs+ examples/Expr/Examples.hs Library- Build-Depends: base+ Build-Depends: base >= 4.5 && < 5+ Ghc-Options: -Wall Exposed-modules:- Language.KURE,- Language.KURE.RewriteMonad, - Language.KURE.Translate,- Language.KURE.Rewrite,- Language.KURE.Combinators,- Language.KURE.Term- Ghc-Options: -Wall+ Language.KURE+ Language.KURE.Combinators+ Language.KURE.Translate+ Language.KURE.Injection+ Language.KURE.Walker+ Language.KURE.Utilities++++