kure 2.0.0 → 2.2.0

raw patch · 14 files changed

+1123/−408 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Language/KURE/Combinators.hs +165/−70
• Language/KURE/Injection.hs +31/−14
• Language/KURE/Translate.hs +126/−41
• Language/KURE/Utilities.hs +219/−46
• Language/KURE/Walker.hs +292/−60
• examples/Expr/AST.hs +0/−8
• examples/Expr/Examples.hs +33/−15
• examples/Expr/Kure.hs +94/−35
• examples/Fib/Examples.hs +49/−23
• examples/Fib/Kure.hs +17/−19
• examples/Lam/AST.hs +0/−50
• examples/Lam/Examples.hs +18/−15
• examples/Lam/Kure.hs +76/−9
• kure.cabal +3/−3

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators, TupleSections #-}+{-# LANGUAGE TypeOperators, TupleSections, FlexibleInstances #-}  -- | -- Module: Language.KURE.Combinators@@ -11,25 +11,31 @@ -- -- 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'.  module Language.KURE.Combinators            ( -- * Monad Combinators-             guardFail-           , condM-           , whenM+             -- ** Monads with a Catch+             MonadCatch(..)+           , (<<+)+           , catchesM            , tryM            , mtryM            , attemptM            , testM            , notM+           , modFailMsg+           , setFailMsg+           , withPatFailMsg+             -- ** Conditionals+           , guardMsg+           , guardM+           , condM+           , whenM              -- * Arrow Combinators-             -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators.-           , result-           , argument-           , idR+             -- ** Categories with a Catch+           , CategoryCatch(..)            , (<+)-           , readerR+           , readerT            , acceptR            , tryR            , attemptR@@ -38,108 +44,197 @@            , (>+>)            , orR            , andR+           , catchesT+             -- ** Basic Routing+             -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators.+           , result+           , argument+           , toFst+           , toSnd+           , swap+           , fork+           , forkFirst+           , forkSecond ) where -import Prelude hiding (id , (.))+import Prelude hiding (id , (.), catch)+ import Control.Monad import Control.Category import Control.Arrow-import Data.Maybe (isJust)+ import Data.Monoid+import Data.List (isPrefixOf) -infixl 3 <+, >+>+infixl 3 >+>, <+, <<+  ------------------------------------------------------------------------------------------ --- | Similar to 'guard', but using 'fail' rather than 'mzero'.-guardFail ::  Monad m => Bool -> String -> m ()-guardFail b msg = unless b (fail msg)+-- | 'Monad's with a catch for 'fail'.+--   The following law is expected to hold:+--+-- > fail msg `catchM` f == f msg --- | 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+class Monad m => MonadCatch m where+  -- | Catch a failing monadic computation.+  catchM :: m a -> (String -> m a) -> m a --- | if-then lifted over a 'Monad'.-whenM ::  Monad m => m Bool -> m a -> m a-whenM mb ma = condM mb ma (fail "condition False")+------------------------------------------------------------------------------------------ +-- | A monadic catch that ignores the error message.+(<<+) :: MonadCatch m => m a -> m a -> m a+ma <<+ mb = ma `catchM` const mb++-- | Select the first monadic computation that succeeds, discarding any thereafter.+catchesM :: MonadCatch m => [m a] -> m a+catchesM = foldr (<<+) (fail "catchesM failed")+ -- | 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+tryM :: MonadCatch m => a -> m a -> m a+tryM a ma = ma <<+ return a  -- | Catch a failing monadic computation, making it succeed with 'mempty'.-mtryM :: (MonadPlus m, Monoid a) => m a -> m a+mtryM :: (MonadCatch m, Monoid a) => m a -> m a mtryM = tryM mempty --- | Catch a failing monadic computation, making it succeed with 'Nothing'.-attemptM :: MonadPlus m => m a -> m (Maybe a)-attemptM = tryM Nothing . liftM Just+-- | Catch a failing monadic computation, making it succeed with an error message.+attemptM :: MonadCatch m => m a -> m (Either String a)+attemptM ma = liftM Right ma `catchM` (return . Left)  -- | Determine if a monadic computation succeeds.-testM :: MonadPlus m => m a -> m Bool-testM = liftM isJust . attemptM+testM :: MonadCatch m => m a -> m Bool+testM ma = liftM (const True) ma <<+ return False  -- | Fail if the 'Monad' succeeds; succeed with @()@ if it fails.-notM :: MonadPlus m => m a -> m ()-notM ma = attemptM ma >>= maybe (return ()) (const mzero)+notM :: MonadCatch m => m a -> m ()+notM ma = condM (testM ma) (fail "notM  of success") (return ()) +-- | Modify the error message of a failing monadic computation.+--   Successful computations are unaffected.+modFailMsg :: MonadCatch m => (String -> String) -> m a -> m a+modFailMsg f ma = ma `catchM` (fail . f)++-- | Set the error message of a failing monadic computation.+--   Successful computations are unaffected.+setFailMsg :: MonadCatch m => String -> m a -> m a+setFailMsg msg = modFailMsg (const msg)++-- | Use the given error message whenever a monadic pattern match failure occurs.+withPatFailMsg :: MonadCatch m => String -> m a -> m a+withPatFailMsg msg = modFailMsg (\ e -> if "Pattern match failure" `isPrefixOf` e then msg else e)+ ------------------------------------------------------------------------------------------ --- | Apply a pure function to the result of an 'Arrow'.-result :: Arrow (~>) => (b -> c) -> (a ~> b) -> (a ~> c)-result f a = a >>^ f+-- | Similar to 'guard', but invokes 'fail' rather than 'mzero'.+guardMsg ::  Monad m => Bool -> String -> m ()+guardMsg b msg = unless b (fail msg) --- | Apply a pure function to the argument to an 'Arrow'.-argument :: Arrow (~>) => (a -> b) -> (b ~> c) -> (a ~> c)-argument f a = f ^>> a+-- | As 'guardMsg', but with a default error message.+guardM ::  Monad m => Bool -> m ()+guardM b = guardMsg b "guard failed" --------------------------------------------------------------------------------+-- | 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 --- | Synonym for 'id'.-idR :: Category (~>) => (a ~> a)-idR = id+-- | if-then lifted over a 'Monad'.+whenM ::  Monad m => m Bool -> m a -> m a+whenM mb ma = condM mb ma (fail "condition False") --- | Synonym for '<+>'.-(<+) :: ArrowPlus (~>) => (a ~> b) -> (a ~> b) -> (a ~> b)-(<+) = (<+>)+------------------------------------------------------------------------------------------ +-- | 'Category's with failure and catching.+--   The following law is expected to hold:+--+-- > failT msg `catchT` f == f msg++class Category (~>) => CategoryCatch (~>) where+  -- | The failing 'Category'.+  failT :: String -> a ~> b++  -- | A catch on 'Category's.+  catchT :: (a ~> b) -> (String -> (a ~> b)) -> (a ~> b)+++-- | Left-biased choice.+(<+) :: CategoryCatch (~>) => (a ~> b) -> (a ~> b) -> (a ~> b)+f <+ g = f `catchT` \ _ -> g+ -- | 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+readerT :: ArrowApply (~>) => (a -> (a ~> b)) -> (a ~> b)+readerT f = (f &&& id) ^>> app --- | 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+-- | Look at the argument to an 'Arrow', and choose to be either the identity arrow or a failure.+acceptR :: (CategoryCatch (~>), ArrowApply (~>)) => (a -> Bool) -> (a ~> a)+acceptR p = readerT $ \ a -> if p a then id else failT "acceptR: predicate failed" --- | Catch a failing 'ArrowPlus', making it into an identity.-tryR :: ArrowPlus (~>) => (a ~> a) -> (a ~> a)-tryR r = r <+> id+-- | Catch a failing 'CategoryCatch', making it into an identity.+tryR :: CategoryCatch (~>) => (a ~> a) -> (a ~> a)+tryR r = r <+ id --- | 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,)+-- | Catch a failing 'Arrow', making it succeed with a Boolean flag.+--   Useful when defining 'Language.KURE.Walker.anyR' instances.+attemptR :: (CategoryCatch (~>), Arrow (~>)) => (a ~> a) -> (a ~> (Bool,a))+attemptR r = (r >>^ (True,)) <+ arr (False,)  -- | 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))+changedR :: (CategoryCatch (~>), ArrowApply (~>), Eq a) => (a ~> a) -> (a ~> a)+changedR r = readerT (\ a -> r >>> acceptR (/=a)) --- | Repeat an 'ArrowPlus' until it fails, then return the result before the failure.+-- | Repeat a 'CategoryCatch' 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 :: CategoryCatch (~>) => (a ~> a) -> (a ~> a) repeatR r = r >>> tryR (repeatR r) --- | 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)+-- | Attempt two 'Arrow's in sequence, succeeding if one or both succeed.+(>+>) :: (CategoryCatch (~>), ArrowApply (~>)) => (a ~> a) -> (a ~> a) -> (a ~> a)+r1 >+> r2 = attemptR r1 >>> readerT (\ (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+orR :: (CategoryCatch (~>), ArrowApply (~>)) => [a ~> a] -> (a ~> a)+orR = foldr (>+>) (failT "orR failed") --- | Sequence a list of 'Arrow's, succeeding if they all succeed.-andR :: Arrow (~>) => [a ~> a] -> (a ~> a)-andR = foldl (>>>) id+-- | Sequence a list of 'Category's, succeeding if all succeed.+andR :: Category (~>) => [a ~> a] -> (a ~> a)+andR = foldr (>>>) id++-- | Select the first 'CategoryCatch' that succeeds, discarding any thereafter.+catchesT :: CategoryCatch (~>) => [a ~> b] -> (a ~> b)+catchesT = foldr (<+) (failT "catchesT failed")++------------------------------------------------------------------------------------------++-- | Apply a pure function to the result of an 'Arrow'.+result :: Arrow (~>) => (b -> c) -> (a ~> b) -> (a ~> c)+result f a = a >>^ f++-- | Apply a pure function to the argument to an 'Arrow'.+argument :: Arrow (~>) => (a -> b) -> (b ~> c) -> (a ~> c)+argument f a = f ^>> a++-- | Apply an 'Arrow' to the first element of a pair, discarding the second element.+toFst :: Arrow (~>) => (a ~> b) -> ((a,x) ~> b)+toFst f = fst ^>> f++-- | Apply an 'Arrow' to the second element of a pair, discarding the first element.+toSnd :: Arrow (~>) => (a ~> b) -> ((x,a) ~> b)+toSnd f = snd ^>> f++-- | A pure 'Arrow' that swaps the elements of a pair.+swap :: Arrow (~>) => ((a,b) ~> (b,a))+swap = arr (\(a,b) -> (b,a))++-- | A pure 'Arrow' that duplicates its argument.+fork :: Arrow (~>) => (a ~> (a,a))+fork = arr (\a -> (a,a))++-- | Tag the result of an 'Arrow' with its argument.+forkFirst :: Arrow (~>) => (a ~> b) -> (a ~> (b , a))+forkFirst sf = fork >>> first sf++-- | Tag the result of an 'Arrow' with its argument.+forkSecond :: Arrow (~>) => (a ~> b) -> (a ~> (a , b))+forkSecond sf = fork >>> second sf  -------------------------------------------------------------------------------

@@ -26,8 +26,12 @@        , retractT        , extractT        , promoteT+       , promoteWithFailMsgT+       -- * Rewrite Injections        , extractR        , promoteR+       , extractWithFailMsgR+       , promoteWithFailMsgR        -- * Lens Injections        , injectL        , retractL@@ -37,6 +41,7 @@ import Control.Arrow  import Language.KURE.Translate+import Language.KURE.Combinators  ------------------------------------------------------------------------------- @@ -64,9 +69,9 @@ 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+-- | Retracts a value and lifts it into a 'MonadCatch', with the possibility of failure.+retractM :: (MonadCatch m, Injection a a') => a' -> m a+retractM = maybe (fail "retractM failed") return . retract  ------------------------------------------------------------------------------- @@ -75,36 +80,48 @@ injectT = arr inject  -- | Lifted 'retract', the 'Translate' fails if the retraction fails.-retractT :: (MonadPlus m, Injection a a') => Translate c m a' a+retractT :: (MonadCatch 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 +-- | As 'promoteT', but takes a custom error message to use if promotion fails.+promoteWithFailMsgT  :: (MonadCatch m, Injection a a') => String -> Translate c m a b -> Translate c m a' b+promoteWithFailMsgT msg t = setFailMsg msg retractT >>> 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+promoteT  :: (MonadCatch m, Injection a a') => Translate c m a b -> Translate c m a' b+promoteT = promoteWithFailMsgT "promoteT failed" +-- | As 'extractR', but takes a custom error message to use if extraction fails.+extractWithFailMsgR :: (MonadCatch m, Injection a a') => String -> Rewrite c m a' -> Rewrite c m a+extractWithFailMsgR msg r = injectT >>> r >>> setFailMsg msg retractT+ -- | 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+extractR :: (MonadCatch m, Injection a a') => Rewrite c m a' -> Rewrite c m a+extractR = extractWithFailMsgR "extractR failed" +-- | As 'promoteR', but takes a custom error message to use if promotion fails.+promoteWithFailMsgR :: (MonadCatch m, Injection a a') => String -> Rewrite c m a -> Rewrite c m a'+promoteWithFailMsgR msg r = setFailMsg msg retractT >>> r >>> injectT+ -- | 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+promoteR  :: (MonadCatch m, Injection a a') => Rewrite c m a -> Rewrite c m a'+promoteR = promoteWithFailMsgR "promoteR failed"  -------------------------------------------------------------------------------  -- | 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)+injectL  :: (MonadCatch m, Injection a a') => Lens c m a a'+injectL = lens $ translate $ \ 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))+retractL :: (MonadCatch m, Injection a a') => Lens c m a' a+retractL = lens $ translate $ \ c -> retractM >=> (\ a -> return ((c,a), injectM))  -------------------------------------------------------------------------------

@@ -8,8 +8,8 @@ -- Portability: ghc -- -- 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' is just a special case of 'Translate', and so any function that operates on 'Translate' is also+-- applicable to 'Rewrite'. -- -- 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@@ -17,9 +17,10 @@ -- "Language.KURE.Combinators" provides some additional combinators that aren't in the standard libraries.  module Language.KURE.Translate-       (  -- * Translations-          Translate(..)+       (-- * Translations+          Translate         , Rewrite+        , apply         , translate         , rewrite         , contextfreeT@@ -27,16 +28,24 @@         , contextT         , exposeT         , mapT-          -- * Lenses+        , sideEffectR+        -- * Bi-directional Translations+        , BiTranslate+        , BiRewrite+        , bidirectional+        , forewardT+        , backwardT+        , whicheverR+        , invert+        -- * Lenses         , Lens         , lens-        , idL-        , tryL-        , composeL-        , sequenceL-        , pureL+        , lensT         , focusR         , focusT+        , testLensT+        , bidirectionalL+        , pureL  ) where @@ -46,20 +55,22 @@ import Control.Category import Control.Arrow import Data.Monoid+import Language.KURE.Combinators  ------------------------------------------------------------------------------------------ --- | 'Translate' is a translation or strategy that translates from a value in a context to a monadic value.+-- | An abstract representation of a transformation from a value of type @a@ in a context @c@ to a monadic value of type @m b@.+--   The 'Translate' type is the basis of the entire KURE library. data Translate c m a b = Translate { -- | Apply a 'Translate' to a value and its context.                                      apply :: c -> a -> m b} --- | A 'Rewrite' is a 'Translate' that shares the same source and target type.-type Rewrite c m a = Translate c m a a- -- | The primitive  way of building a 'Translate'. translate :: (c -> a -> m b) -> Translate c m a b translate = Translate +-- | A 'Translate' that shares the same source and target type.+type Rewrite c m a = Translate c m a a+ -- | The primitive way of building a 'Rewrite'. rewrite :: (c -> a -> m a) -> Rewrite c m a rewrite = translate@@ -86,6 +97,10 @@ mapT :: Monad m => Translate c m a b -> Translate c m [a] [b] mapT t = translate (mapM . apply t) +-- | An identity 'Rewrite' with side-effects.+sideEffectR :: Monad m => (c -> a -> m ()) -> Rewrite c m a+sideEffectR f = translate f >> id+ ------------------------------------------------------------------------------------------  -- | Lifting through a Reader transformer, where (c,a) is the read-only environment.@@ -126,6 +141,13 @@    fail = constT . fail  -- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadCatch m => MonadCatch (Translate c m a) where++-- catchM :: Translate c m a b -> (String -> Translate c m a b) -> Translate c m a b+   catchM t1 t2 = translate $ \ c a -> apply t1 c a `catchM` \ msg -> apply (t2 msg) c a+++-- | 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@@ -134,6 +156,8 @@ -- 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 @@ -143,13 +167,23 @@ --  (.) :: 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' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance MonadCatch m => CategoryCatch (Translate c m) where++-- failT :: String -> Translate c m a b+   failT = fail++-- catchT :: Translate c m a b -> (String -> Translate c m a b) -> Translate c m a b+   catchT = catchM++ -- | 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 :: Translate c m 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)@@ -176,6 +210,8 @@ -- 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 @@ -187,43 +223,92 @@  ------------------------------------------------------------------------------------------ --- | 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)+-- | An undirected 'Translate'.+data BiTranslate c m a b = BiTranslate {forewardT :: Translate c m a b, -- ^ Extract the foreward 'Translate' from a 'BiTranslate'.+                                        backwardT :: Translate c m b a  -- ^ Extract the backward 'Translate' from a 'BiTranslate'.+                                       } --- | '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+-- | A 'BiTranslate' that shares the same source and target type.+type BiRewrite c m a = BiTranslate c m a a --- | Identity 'Lens'.-idL :: Monad m => Lens c m a a-idL = lens $ \ c a -> return ((c,a), return)+-- | Construct a 'BiTranslate' from two opposite 'Translate's.+bidirectional :: Translate c m a b -> Translate c m b a -> BiTranslate c m a b+bidirectional = BiTranslate --- | 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+-- | Try the 'BiRewrite' forewards, then backwards if that fails.+--   Useful when you know which rule you want to apply, but not which direction to apply it in.+whicheverR :: MonadCatch m => BiRewrite c m a -> Rewrite c m a+whicheverR r = forewardT r <+ backwardT r --- | 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)+-- | Invert the forewards and backwards directions of a 'BiTranslate'.+invert :: BiTranslate c m a b -> BiTranslate c m b a+invert (BiTranslate t1 t2) = BiTranslate t2 t1 --- | Sequence a list of endo'Lens's.-sequenceL :: MonadPlus m => [Lens c m a a] -> Lens c m a a-sequenceL = foldr composeL idL+instance Monad m => Category (BiTranslate c m) where+-- id :: BiTranslate c m a a+   id = bidirectional id id --- | 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))+-- (.) :: BiTranslate c m b d -> BiTranslate c m a b -> BiTranslate c m a d+   (BiTranslate f1 b1) . (BiTranslate f2 b2) = BiTranslate (f1 . f2) (b2 . b1) +------------------------------------------------------------------------------------------++-- | A 'Lens' is a way to focus on a sub-structure of type @b@ from a structure of type @a@.+newtype Lens c m a b = Lens { -- | Convert a 'Lens' into a 'Translate' that produces a sub-structure (and its context) and an unfocussing function.+                              lensT :: Translate c m a ((c,b), b -> m a)}++-- | The primitive way of building a 'Lens'.+--   If the unfocussing function is applied to the value focussed on then it should succeed,+--   and produce the same value as the original argument (of type @a@).+lens :: Translate c m a ((c,b), b -> m a) -> Lens c m a b+lens = Lens+ -- | 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+focusR l r = do ((c,b),k) <- lensT l+                constT (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+focusT l t = do ((c,b),_) <- lensT l+                constT (apply t c b)++-- | Check if the focusing succeeds, and additionally whether unfocussing from an unchanged value would succeed.+testLensT :: MonadCatch m => Lens c m a b -> Translate c m a Bool+testLensT l = testM (focusR l id)++instance Monad m => Category (Lens c m) where++-- id :: Lens c m a a+   id = lens $ translate $ \ c a -> return ((c,a), return)++-- (.) :: Lens c m b d -> Lens c m a b -> Lens c m a d+   l2 . l1 = lens $ translate $ \ ca a -> do ((cb,b),kb) <- apply (lensT l1) ca a+                                             ((cd,d),kd) <- apply (lensT l2) cb b+                                             return ((cd,d),kd >=> kb)+++-- | A 'Lens' is deemed to have failed (and thus can be caught) if either it fails on the way down, or,+--   crucially, if it would fail on the way up for an unmodified value.  However, actual failure on the way up is not caught+--   (as by then it is too late to use an alternative 'Lens').  This means that, in theory, a use of 'catch' could cause a succeeding 'Lens' application to fail.+--   But provided 'lens' is used correctly, this should never happen.++instance MonadCatch m => CategoryCatch (Lens c m) where++-- failT :: String -> Lens c m a b+   failT = lens . fail++-- catch :: Lens c m a b -> (String -> Lens c m a b) -> Lens c m a b+   l1 `catchT` l2 = lens (attemptM (focusR l1 id) >>= either (lensT . l2) (const (lensT l1)))++-- | Construct a 'Lens' from a 'BiTranslate'.+bidirectionalL :: Monad m => BiTranslate c m a b -> Lens c m a b+bidirectionalL (BiTranslate tf tg) = lens $ do c <- contextT+                                               b <- tf+                                               return ((c,b), apply tg c)++-- | Construct a 'Lens' from two pure functions.+pureL :: Monad m => (a -> b) -> (b -> a) -> Lens c m a b+pureL f g = bidirectionalL $ bidirectional (arr f) (arr g)  ------------------------------------------------------------------------------------------

@@ -7,24 +7,39 @@ -- 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.+-- This module contains various utilities that can be useful to users of KURE, but are not essential.  module Language.KURE.Utilities-       ( -- * Generic Combinators+       ( -- * The KURE Monad+         KureMonad+       , runKureMonad+       , fromKureMonad+         -- * Error Messages+       , missingChild+         -- * Generic Combinators          -- $genericdoc-         allTgeneric+       , allTgeneric+       , oneTgeneric        , allRgeneric        , anyRgeneric+       , oneRgeneric        , childLgeneric          -- * Attempt Combinators-         -- $attemptdoc+         -- ** anyR Support+         -- $attemptAnydoc        , attemptAny2        , attemptAny3+       , attemptAny4        , attemptAnyN        , attemptAny1N-         -- * Error Messages-       , missingChildL+         -- * oneR Support+         -- $attemptOnedoc+       , withArgumentT+       , attemptOne2+       , attemptOne3+       , attemptOne4+       , attemptOneN+       , attemptOne1N          -- * Child Combinators          -- $childLdoc        , childLaux@@ -41,6 +56,7 @@        , childLMofN ) where +import Control.Applicative import Control.Monad import Control.Arrow @@ -53,6 +69,48 @@  ------------------------------------------------------------------------------- +-- | A basic error 'Monad'.  KURE users may use either 'KureMonad' or their own 'Monad'(s).+data KureMonad a = Failure String | Success a deriving (Eq, Show)++-- | Eliminator for 'KureMonad'.+runKureMonad :: (a -> b) -> (String -> b) -> KureMonad a -> b+runKureMonad _ f (Failure msg) = f msg+runKureMonad s _ (Success a)   = s a++-- | Get the value from a 'KureMonad', providing a function to handle the error case.+fromKureMonad :: (String -> a) -> KureMonad a -> a+fromKureMonad = runKureMonad id++instance Monad KureMonad where+-- return :: a -> KureMonad a+   return = Success++-- (>>=) :: KureMonad a -> (a -> KureMonad b) -> KureMonad b+   (Success a)   >>= f = f a+   (Failure msg) >>= _ = Failure msg++-- fail :: String -> KureMonad a+   fail = Failure++-- | 'KureMonad' is the minimal monad that can be an instance of 'MonadCatch'.+instance MonadCatch KureMonad where+-- catchM :: KureMonad a -> (a -> KureMonad b) -> KureMonad b+   (Success a)   `catchM` _ = Success a+   (Failure msg) `catchM` f = f msg++instance Functor KureMonad where+-- fmap :: (a -> b) -> KureMonad a -> KureMonad b+   fmap = liftM++instance Applicative KureMonad where+-- pure :: a -> KureMonad a+   pure = return++-- (<*>) :: KureMonad (a -> b) -> KureMonad a -> KureMonad b+   (<*>) = ap++------------------------------------------------------------------------------------------+ -- $genericdoc -- These functions are to aid with defining 'Walker' instances for the 'Generic' type. -- See the \"Expr\" example.@@ -60,65 +118,149 @@ 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 +oneTgeneric :: Walker c m a => Translate c m (Generic a) b -> c -> a -> m b+oneTgeneric t c a = inject `liftM` apply (oneT 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 +oneRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a)+oneRgeneric r c a = inject `liftM` apply (oneR 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+childLgeneric n c a = (liftM.second.result.liftM) inject $ apply (lensT $ childL n) c a  ------------------------------------------------------------------------------- --- $attemptdoc+-- $attemptAnydoc -- 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.+-- See the \"Expr\" example, or the HERMIT package. +attemptAny2' :: Monad m => (a1 -> a2 -> r) -> (Bool,a1) -> (Bool,a2) -> m r+attemptAny2' f (b1,a1) (b2,a2) = if b1 || b2+                                  then return (f a1 a2)+                                  else fail "failed for both children"++attemptAny3' :: Monad m => (a1 -> a2 -> a3 -> r) -> (Bool,a1) -> (Bool,a2) -> (Bool,a3) -> m r+attemptAny3' f (b1,a1) (b2,a2) (b3,a3) = if b1 || b2 || b3+                                          then return (f a1 a2 a3)+                                          else fail "failed for all three children"++attemptAny4' :: Monad m => (a1 -> a2 -> a3 -> a4 -> r) -> (Bool,a1) -> (Bool,a2) -> (Bool,a3) -> (Bool,a4) -> m r+attemptAny4' f (b1,a1) (b2,a2) (b3,a3) (b4,a4) = if b1 || b2 || b3 || b4+                                                  then return (f a1 a2 a3 a4)+                                                  else fail "failed for all four children"++attemptAnyN' :: Monad m => ([a] -> b) -> [(Bool,a)] -> m b+attemptAnyN' f bas = let (bs,as) = unzip bas+                      in if or bs+                          then return (f as)+                          else fail ("failed for all " ++ show (length bs) ++ " children")++attemptAny1N' :: Monad m => (a1 -> [a2] -> r) -> (Bool,a1) -> [(Bool,a2)] -> m r+attemptAny1N' f (b,a) bas = let (bs,as) = unzip bas+                             in if or (b:bs)+                                 then return (f a as)+                                 else fail ("failed for all " ++ show (1 + length bs) ++ " children")+ 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."+attemptAny2 f = liftArgument2 (attemptAny2' f)  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."+attemptAny3 f = liftArgument3 (attemptAny3' f) +attemptAny4 :: Monad m => (a1 -> a2 -> a3 -> a4 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m (Bool,a3) -> m (Bool,a4) -> m r+attemptAny4 f = liftArgument4 (attemptAny4' f)+ 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.")+attemptAnyN f = liftArgumentN (attemptAnyN' f)  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.")+attemptAny1N f = liftArgument1N (attemptAny1N' f)  ------------------------------------------------------------------------------- --- | A failing 'Lens' with a standard error message for when the child index is out of bounds.+-- -- | Catch a failing 'Arrow', making it succeed with an error message, and passing through the argument value.+-- --   Useful when defining 'Language.KURE.Walker.oneR' instances.+-- attemptT :: MonadCatch m => Translate c m a b -> Translate c m a (Either String b, a)+-- attemptT t = forkFirst (attemptM t) -missingChildL :: Monad m => Int -> Lens c m a b-missingChildL n = fail ("There is no child number " ++ show n ++ ".")+-- $attemptOnedoc+-- These are useful when defining congruence combinators that succeed if one child rewrite succeeds+-- (and the remainder are then discarded).+-- As well as being generally useful, such combinators are helpful when defining 'oneR' instances.+-- See the \"Expr\" example, or the HERMIT package. +-- | Return the monadic result of a 'Translate' and pair it with the argument.+withArgumentT :: Monad m => Translate c m a b -> Translate c m a (m b, a)+withArgumentT t = do (c,a) <- exposeT+                     return (apply t c a, a)++attemptOne1' :: Monad m => (a -> r) -> (m a, a) -> m r+attemptOne1' f (ma , _) = f `liftM` ma++attemptOne2' :: MonadCatch m => (a -> b -> r) -> (m a, a) -> (m b, b) -> m r+attemptOne2' f (ma , a) mbb@(_ , b) = (do a' <- ma+                                          return (f a' b)+                                      ) <<+ attemptOne1' (f a) mbb++attemptOne3' :: MonadCatch m => (a -> b -> c -> r) -> (m a, a) -> (m b, b) -> (m c, c) -> m r+attemptOne3' f (ma , a) mbb@(_ , b) mcc@(_ , c) = (do a' <- ma+                                                      return (f a' b c)+                                                  ) <<+ attemptOne2' (f a) mbb mcc++attemptOne4' :: MonadCatch m => (a -> b -> c -> d -> r) -> (m a, a) -> (m b, b) -> (m c, c) -> (m d, d) -> m r+attemptOne4' f (ma , a) mbb@(_ , b) mcc@(_ , c) mdd@(_ , d) = (do a' <- ma+                                                                  return (f a' b c d)+                                                              ) <<+ attemptOne3' (f a) mbb mcc mdd++attemptOneN' :: MonadCatch m => ([a] -> r) -> [(m a, a)] -> m r+attemptOneN' _ []                = fail "failed for all children"+attemptOneN' f [maa]             = attemptOne1' (f . (:[])) maa+attemptOneN' f ((ma , a) : maas) = (do a' <- ma+                                       return $ f (a' : map snd maas)+                                   ) <<+ attemptOneN' (f . (a:)) maas++attemptOne1N' :: MonadCatch m => (a -> [b] -> r) -> (m a, a) -> [(m b, b)] -> m r+attemptOne1N' f (ma , a) mbbs = (do a' <- ma+                                    return $ f a' (map snd mbbs)+                                ) <<+ attemptOneN' (f a) mbbs+++attemptOne2 :: MonadCatch m => (a -> b -> r) -> m (m a, a) -> m (m b, b) -> m r+attemptOne2 f = liftArgument2 (attemptOne2' f)++attemptOne3 :: MonadCatch m => (a -> b -> c -> r) -> m (m a, a) -> m (m b, b) -> m (m c, c) -> m r+attemptOne3 f = liftArgument3 (attemptOne3' f)++attemptOne4 :: MonadCatch m => (a -> b -> c -> d -> r) -> m (m a, a) -> m (m b, b) -> m (m c, c) -> m (m d, d) -> m r+attemptOne4 f = liftArgument4 (attemptOne4' f)++attemptOneN :: MonadCatch m => ([a] -> r) -> [m (m a, a)] -> m r+attemptOneN f = liftArgumentN (attemptOneN' f)++attemptOne1N :: MonadCatch m => (a -> [b] -> r) -> m (m a, a) -> [m (m b, b)] -> m r+attemptOne1N f = liftArgument1N (attemptOne1N' f)+ ------------------------------------------------------------------------------- +-- | A standard error message for when the child index is out of bounds.++missingChild :: Int -> String+missingChild n = "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';+-- It would be nice if they were further expanded to include the calls of 'id' and 'exposeT'; -- however this would create a plethora of additional cases as the number (and positions) -- of interesting children would be additional dimensions. --@@ -129,40 +271,40 @@ -- -- 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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 :: (MonadCatch m, Node 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))  -------------------------------------------------------------------------------@@ -172,5 +314,36 @@ atIndex i f as = [ if n == i then f a else a                  | (a,n) <- zip as [0..]                  ]++-------------------------------------------------------------------------------++-- liftResult :: Monad m => (a -> b) -> (a -> m b)+-- liftResult = result return++-- liftResult2 :: Monad m => (a -> b -> c) -> (a -> b -> m c)+-- liftResult2 = (result.result) return++-- liftResult3 :: Monad m => (a -> b -> c -> d) -> (a -> b -> c -> m d)+-- liftResult3 = (result.result.result) return++-- liftResult4 :: Monad m => (a -> b -> c -> d -> e) -> (a -> b -> c -> d -> m e)+-- liftResult4 = (result.result.result.result) return++liftArgument2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c+liftArgument2 f ma mb = join (liftM2 f ma mb)++liftArgument3 :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d+liftArgument3 f ma mb mc = join (liftM3 f ma mb mc)++liftArgument4 :: Monad m => (a -> b -> c -> d -> m e) -> m a -> m b -> m c -> m d -> m e+liftArgument4 f ma mb mc md = join (liftM4 f ma mb mc md)++liftArgumentN :: Monad m => ([a] -> m b) -> [m a] -> m b+liftArgumentN f mas = sequence mas >>= f++liftArgument1N :: Monad m => (a -> [b] -> m c) -> m a -> [m b] -> m c+liftArgument1N f ma mbs = do a  <- ma+                             bs <- sequence mbs+                             f a bs  -------------------------------------------------------------------------------

@@ -12,42 +12,84 @@ -- 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.+-- Deliberately, there is no mechanism for \"ascending\" the tree.  module Language.KURE.Walker-        ( -- * Traversal Classes-          Term(..)+        ( -- * Nodes+          Node(..)+        , numChildrenT+        , hasChild+        , hasChildT++          -- * Tree Walkers         , Walker(..)          -- * Rewrite Traversals         , childR         , alltdR-        , anytdR         , allbuR-        , anybuR         , allduR+        , anytdR+        , anybuR         , anyduR-        , tdpruneR+        , onetdR+        , onebuR+        , prunetdR         , innermostR          -- * Translate Traversals         , childT         , foldtdT         , foldbuT-        , tdpruneT+        , onetdT+        , onebuT+        , prunetdT         , crushtdT         , crushbuT+        , collectT+        , collectPruneT -        -- * Building Lenses+        -- * Paths+        -- ** Absolute Paths+        , AbsolutePath+        , rootAbsPath+        , extendAbsPath+        , PathContext(..)+        , absPathT+        -- ** Relative Paths         , Path+        , rootPath+        , pathsToT+        , onePathToT+        , oneNonEmptyPathToT+        , prunePathsToT+        , uniquePathToT+        , uniquePrunePathToT++        -- * Using Paths+        -- ** Building Lenses from Paths         , pathL         , exhaustPathL         , repeatPathL+        , rootL++        -- ** Applying transformations at the end of Paths+        ,  pathR+        ,  pathT++        -- ** Testing Paths+        ,  testPathT++ ) where +import Prelude hiding (id)+ import Data.Monoid+import Data.List import Control.Monad import Control.Arrow+import Control.Category hiding ((.))  import Language.KURE.Combinators import Language.KURE.Translate@@ -55,73 +97,125 @@  ------------------------------------------------------------------------------------------ --- | 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+-- | A 'Node' is any node in the tree that you wish to be able to traverse. -  -- | 'Generic' is a sum of all the interesting sub-types, transitively, of @a@.+class (Injection a (Generic a), Generic a ~ Generic (Generic a)) => Node a where++  -- | 'Generic' is a sum of all the types of the sub-nodes, 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'.+  -- will have a new datatype for the 'Generic', which will also be an instance of class 'Node'.   type Generic a :: * -  -- | Count the number of interesting children.+  -- | Count the number of immediate child 'Node's.   numChildren :: a -> Int +-- | Lifted version of 'numChildren'.+numChildrenT :: (Monad m, Node a) => Translate c m a Int+numChildrenT = arr numChildren++-- | Check if a 'Node' has a child of the specified index.+hasChild :: Node a => Int -> a -> Bool+hasChild n a = (0 <= n) && (n < numChildren a)++-- | Lifted version of 'hasChild'.+hasChildT :: (Monad m, Node a) => Int -> Translate c m a Bool+hasChildT = arr . hasChild+ ------------------------------------------------------------------------------- --- | 'Walker' captures the ability to walk over a 'Term' applying 'Rewrite's,---   using a specific context @c@ and a 'MonadPlus' @m@.+-- | 'Walker' captures the ability to walk over a tree of 'Node's,+--   using a specific context @c@ and a 'MonadCatch' @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.+--   Default definitions are provided for 'allT', 'oneT', 'allR', 'anyR' and 'oneR', 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+class (MonadCatch m, Node a) => Walker c m a where -  -- | Construct a 'Lens' pointing at the n-th interesting child of this node.+  -- | Construct a 'Lens' to the n-th child '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.+  -- | Apply a 'Generic' 'Translate' to all immediate children, 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)] ]+  allT t = modFailMsg ("allT failed: " ++) $+           do n <- numChildrenT+              mconcat (childrenT n (const t)) -  -- | Apply a 'Generic' 'Rewrite' to all interesting children of this node, succeeding if they all succeed.+  -- | Apply a 'Generic' 'Translate' to the first immediate child for which it can succeed.+  oneT :: Translate c m (Generic a) b -> Translate c m a b+  oneT t = setFailMsg "oneT failed" $+           do n <- numChildrenT+              catchesT (childrenT n (const t))++  -- | Apply a 'Generic' 'Rewrite' to all immediate children, 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)] ]+  allR r = modFailMsg ("allR failed: " ++) $+           do n <- numChildrenT+              andR (childrenR n (const r)) -  -- | Apply 'Generic' 'Rewrite' to all interesting children of this node, suceeding if any succeed.+  -- | Apply a 'Generic' 'Rewrite' to all immediate children, 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)] ]+  anyR r = setFailMsg "anyR failed" $+           do n <- numChildrenT+              orR (childrenR n (const r)) --- | Apply a 'Translate' to a specific child.+  -- | Apply a 'Generic' 'Rewrite' to the first immediate child for which it can succeed.+  oneR :: Rewrite c m (Generic a) -> Rewrite c m a+  oneR r = setFailMsg "oneR failed" $+           do n <- numChildrenT+              catchesT (childrenR n (const r))++-- | Apply a 'Translate' to a specified 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.+-- | Apply a 'Rewrite' to a specified child. childR :: Walker c m a => Int -> Rewrite c m (Generic a) -> Rewrite c m a childR n = focusR (childL n) +childrenT :: Walker c m a => Int -> (Int -> Translate c m (Generic a) b) -> [Translate c m a b]+childrenT n ts = [ childT i (ts i) | i <- [0..(n-1)] ]++childrenR :: Walker c m a => Int -> (Int -> Rewrite c m (Generic a)) -> [Rewrite c m a]+childrenR n rs = [ childR i (rs i) | i <- [0..(n-1)] ]+ ------------------------------------------------------------------------------- --- | Fold a tree in a top-down manner, using a single 'Translate' for each node.+-- | 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)+foldtdT t = modFailMsg ("foldtdT failed: " ++) $+            let go = t `mappend` allT go+             in go --- | Fold a tree in a bottom-up manner, using a single 'Translate' for each node.+-- | 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+foldbuT t = modFailMsg ("foldbuT failed: " ++) $+            let go = allT go `mappend` t+             in go --- | 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)+-- | Apply a 'Translate' to the first 'Node' for which it can succeed, in a top-down traversal.+onetdT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+onetdT t = setFailMsg "onetdT failed" $+           let go = t <+ oneT go+            in go +-- | Apply a 'Translate' to the first 'Node' for which it can succeed, in a bottom-up traversal.+onebuT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+onebuT t = setFailMsg "onetdT failed" $+           let go = oneT go <+ t+            in go++-- | Attempt to apply a 'Translate' in a top-down manner, pruning at successes.+prunetdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+prunetdT t = setFailMsg "prunetdT failed" $+             let go = t <+ allT go+              in go+ -- | 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)@@ -130,58 +224,196 @@ 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) +-- | An always successful traversal that collects the results of all successful applications of a 'Translate' in a list.+collectT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) [b]+collectT t = crushtdT (t >>^ (: []))++-- | Like 'collectT', but does not traverse below successes.+collectPruneT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) [b]+collectPruneT t = prunetdT (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)+alltdR r = modFailMsg ("alltdR failed: " ++) $+           let go = r >>> allR go+            in go  -- | 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+allbuR r = modFailMsg ("allbuR failed: " ++) $+           let go = allR go >>> r+            in go  -- | 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+allduR r = modFailMsg ("allduR failed: " ++) $+           let go = r >>> allR go >>> r+            in go +-- | 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 = setFailMsg "anytdR failed" $+           let go = r >+> anyR go+            in go++-- | 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 = setFailMsg "anybuR failed" $+           let go = anyR go >+> r+            in go+ -- | 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+anyduR r = setFailMsg "anyduR failed" $+           let go = r >+> anyR go >+> r+            in go --- | 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)+-- | Apply a 'Rewrite' to the first 'Node' for which it can succeed, in a top-down traversal.+onetdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+onetdR r = setFailMsg "onetdR failed" $+           let go = r <+ oneR go+            in go +-- | Apply a 'Rewrite' to the first 'Node' for which it can succeed, in a bottom-up traversal.+onebuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+onebuR r = setFailMsg "onetdR failed" $+           let go = oneR go <+ r+            in go++-- | Attempt to apply a 'Rewrite' in a top-down manner, pruning at successful rewrites.+prunetdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+prunetdR r = setFailMsg "prunetdR failed" $+             let go = r <+ anyR go+              in go+ -- | 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))+innermostR r = setFailMsg "innermostR failed" $+               let go = anybuR (r >>> tryR go)+                in go  ------------------------------------------------------------------------------- --- | A 'Path' is a list of 'Int's, where each 'Int' specifies which interesting child to descend to at each step.+-- | A path from the root.+newtype AbsolutePath = AbsolutePath [Int]++instance Show AbsolutePath where+  show (AbsolutePath p) = show (reverse p)++-- | The (empty) 'AbsolutePath' to the root.+rootAbsPath :: AbsolutePath+rootAbsPath = AbsolutePath []++-- | Extend an 'AbsolutePath' by one descent.+extendAbsPath :: Int -> AbsolutePath -> AbsolutePath+extendAbsPath n (AbsolutePath ns) = AbsolutePath (n:ns)++-- | Contexts that are instances of 'PathContext' contain the current 'AbsolutePath'.+--   Any user-defined combinators (typically 'childL' and congruence combinators) should update the 'AbsolutePath' using 'extendAbsPath'.+class PathContext c where+  -- | Find the current path.+  contextPath :: c -> AbsolutePath++-- | The simplest instance of 'PathContext' is 'AbsolutePath' itself.+instance PathContext AbsolutePath where+-- contextPath :: AbsolutePath -> AbsolutePath+   contextPath p = p++-- | Find the 'AbsolutePath' to the current 'Node'.+absPathT :: (PathContext c, Monad m) => Translate c m a AbsolutePath+absPathT = contextT >>^ contextPath++-------------------------------------------------------------------------------++-- | A path is a route to descend the tree from an arbitrary 'Node'. type Path = [Int] +-- | Convert an 'AbsolutePath' into a 'Path' starting at the root.+rootPath :: AbsolutePath -> Path+rootPath (AbsolutePath p) = reverse p++--  Provided the first 'AbsolutePath' is a prefix of the second 'AbsolutePath',+--  computes the 'Path' from the end of the first to the end of the second.+rmPathPrefix :: AbsolutePath -> AbsolutePath -> Maybe Path+rmPathPrefix (AbsolutePath p1) (AbsolutePath p2) = do guard (p1 `isSuffixOf` p2)+                                                      return (drop (length p1) (reverse p2))++--  Construct a 'Path' from the current 'Node' to the end of the given 'AbsolutePath', provided that 'AbsolutePath' passes through the current 'Node'.+abs2pathT :: (PathContext c, Monad m) => AbsolutePath -> Translate c m a Path+abs2pathT there = do here <- absPathT+                     maybe (fail "Absolute path does not pass through current node.") return (rmPathPrefix here there)++-- | Find the 'Path's to every 'Node' that satisfies the predicate.+pathsToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) [Path]+pathsToT q = collectT (acceptR q >>> absPathT) >>= mapM abs2pathT++-- | Find the 'Path' to the first 'Node' that satisfies the predicate (in a pre-order traversal).+onePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+onePathToT q = setFailMsg "No matching nodes found." $+               onetdT (acceptR q >>> absPathT) >>= abs2pathT++-- | Find the 'Path' to the first descendent 'Node' that satisfies the predicate (in a pre-order traversal).+oneNonEmptyPathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+oneNonEmptyPathToT q = setFailMsg "No matching nodes found." $+                       do n <- numChildrenT+                          catchesT $ childrenT n (\ i -> onePathToT q >>^ (i:))++-- | Find the 'Path's to every 'Node' that satisfies the predicate, ignoring 'Node's below successes.+prunePathsToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) [Path]+prunePathsToT q = collectPruneT (acceptR q >>> absPathT) >>= mapM abs2pathT+++-- local function used by uniquePathToT and uniquePrunePathToT+requireUniquePath :: Monad m => Translate c m [Path] Path+requireUniquePath = contextfreeT $ \ ps -> case ps of+                                             []  -> fail "No matching nodes found."+                                             [p] -> return p+                                             _   -> fail $ "Ambiguous: " ++ show (length ps) ++ " matching nodes found."++-- | Find the 'Path' to the 'Node' that satisfies the predicate, failing if that does not uniquely identify a 'Node'.+uniquePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+uniquePathToT q = pathsToT q >>> requireUniquePath++-- | Build a 'Path' to the 'Node' that satisfies the predicate, failing if that does not uniquely identify a 'Node' (ignoring 'Node's below successes).+uniquePrunePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath++-------------------------------------------------------------------------------+ -- | 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+pathL = andR . map childL --- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed.+-- | 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)+exhaustPathL = foldr (\ n l -> tryR (childL n >>> l)) id  -- | 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)+repeatPathL p = tryR (pathL p >>> repeatPathL p)++-- | Build a 'Lens' from the root to a point specified by an 'AbsolutePath'.+rootL :: (Walker c m a, a ~ Generic a) => AbsolutePath -> Lens c m (Generic a) (Generic a)+rootL = pathL . rootPath++-------------------------------------------------------------------------------++-- | Apply a 'Rewrite' at a point specified by a 'Path'.+pathR :: (Walker c m a, a ~ Generic a) => Path -> Rewrite c m (Generic a) -> Rewrite c m (Generic a)+pathR = focusR . pathL++-- | Apply a 'Translate' at a point specified by a 'Path'.+pathT :: (Walker c m a, a ~ Generic a) => Path -> Translate c m (Generic a) b -> Translate c m (Generic a) b+pathT = focusT . pathL++-------------------------------------------------------------------------------++-- | Check if it is possible to construct a 'Lens' along this path from the current 'Node'.+testPathT :: (Walker c m a, a ~ Generic a) => Path -> Translate c m a Bool+testPathT = testLensT . pathL  -------------------------------------------------------------------------------

@@ -21,11 +21,3 @@   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):)-------------------------------------------------------------------

@@ -10,7 +10,7 @@  inlineR :: RewriteE Expr inlineR = do (c, Var v) <- exposeT-             constT (lookup v c)+             constT (lookupDef v c)  inlineGR :: RewriteE GenericExpr inlineGR = promoteR inlineR@@ -25,17 +25,31 @@                   (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))-               )+result1a :: Expr+result1a = 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+result1b :: Expr+result1b = ESeq (Seq (Assign "m" (Lit 7))+                     (Assign "n" (Add (Lit 1) (Lit 2)))+                )+                (Add (Lit 7)+                     (Var "n")+                ) +test1a :: Bool+test1a = applyE (extractR (anytdR inlineGR)) expr1 == Right result1a++test1b :: Bool+test1b = applyE (extractR (onebuR inlineGR)) expr1 == Right result1b++test1c :: Bool+test1c = applyE (extractR (onetdR inlineGR)) expr1 == Right result1b+ expr2 :: Expr expr2 = ESeq (Seq (Assign "m" (Lit 7))                   (Assign "n" (Add (Lit 1) (Lit 2)))@@ -51,8 +65,9 @@                (Add (Lit 7)                     (Var "x")                )+ test2 :: Bool-test2 = apply (extractR (anytdR inlineGR)) [] expr2 == Just result2+test2 = applyE (extractR (anytdR inlineGR)) expr2 == Right result2  expr3 :: Expr expr3 = ESeq (Assign "m" (Lit 7)@@ -61,15 +76,18 @@                   (Var "x")              ) -test3 :: Bool-test3 = apply (extractR (anytdR inlineGR)) [] expr3 == Nothing+test3a :: Bool+test3a = applyE (extractR (anytdR inlineGR)) expr3 == Left "anytdR failed" +test3b :: Bool+test3b = applyE (extractR (onetdR inlineGR)) expr3 == Left "onetdR failed"+ -----------------------------------------------------------------  checkTests :: Bool-checkTests = and [ test1+checkTests = and [ test1a, test1b, test1c                  , test2-                 , test3+                 , test3a, test3b                  ]  -----------------------------------------------------------------

@@ -2,6 +2,9 @@  module Expr.Kure where +import Prelude hiding (id , (.))++import Control.Category import Control.Applicative  import Data.Monoid@@ -12,22 +15,47 @@  import Expr.AST +-- NOTE: allT, oneT, allR, anyR and oneR have been defined just to serve as examples:+--       the difference in efficiency with the default instances is negligible.+ --------------------------------------------------------------------------- --- NOTE: allT, allR and anyR have been defined to serve as examples,---       but using the default instances would be fine (just slightly less efficient).+data Context = Context AbsolutePath [(Name,Expr)] -- A list of bindings.+                                                  -- We assume no shadowing in the language. +instance PathContext Context where+  contextPath (Context p _) = p++addDef :: Name -> Expr -> Context -> Context+addDef v e (Context p defs) = Context p ((v,e):defs)++updateContextCmd :: Cmd -> Context -> Context+updateContextCmd (Seq c1 c2)  = updateContextCmd c2 . updateContextCmd c1+updateContextCmd (Assign v e) = (addDef v e)++(@@) :: Context -> Int -> Context+(Context p defs) @@ n = Context (extendAbsPath n p) defs++initialContext :: Context+initialContext = Context rootAbsPath []++lookupDef :: Name -> Context -> KureMonad Expr+lookupDef v (Context _ defs) = maybe (fail $ v ++ " not found in context") return $ lookup v defs+ --------------------------------------------------------------------------- -type TranslateE a b = Translate Context Maybe a b+type TranslateE a b = Translate Context KureMonad a b type RewriteE a = TranslateE a a +applyE :: TranslateE a b -> a -> Either String b+applyE t = runKureMonad Right Left . apply t initialContext+ ---------------------------------------------------------------------------  data GenericExpr = GExpr Expr                  | GCmd Cmd -instance Term GenericExpr where+instance Node GenericExpr where   type Generic GenericExpr = GenericExpr    numChildren (GExpr e) = numChildren e@@ -35,16 +63,20 @@  --------------------------------------------------------------------------- -instance Walker Context Maybe GenericExpr where+instance Walker Context KureMonad GenericExpr where -  childL n = lens $ \ c g -> case g of-                               GExpr e -> childLgeneric n c e-                               GCmd cm -> childLgeneric n c cm+  childL n = lens $ translate $ \ 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 +  oneT t = translate $ \ c g -> case g of+                                  GExpr e -> oneTgeneric t c e+                                  GCmd cm -> oneTgeneric t c cm+   allR r = rewrite $ \ c g -> case g of                                 GExpr e -> allRgeneric r c e                                 GCmd cm -> allRgeneric r c cm@@ -53,6 +85,10 @@                                 GExpr e -> anyRgeneric r c e                                 GCmd cm -> anyRgeneric r c cm +  oneR r = rewrite $ \ c g -> case g of+                                GExpr e -> oneRgeneric r c e+                                GCmd cm -> oneRgeneric r c cm+ ---------------------------------------------------------------------------  instance Injection Expr GenericExpr where@@ -61,7 +97,7 @@   retract (GExpr e) = Just e   retract _         = Nothing -instance Term Expr where+instance Node Expr where   type Generic Expr = GenericExpr    numChildren (Add _ _)  = 2@@ -69,32 +105,37 @@   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+instance Walker Context KureMonad Expr where+  childL n = lens $+    case n of+      0 ->    addT  exposeT id (childL0of2 Add)+           <+ eseqT exposeT id (childL0of2 ESeq)+      1 ->    addT  id exposeT (childL1of2 Add)+           <+ eseqT id exposeT (childL1of2 ESeq)+      _ -> fail (missingChild n)    allT t =  varT (\ _ -> mempty)          <+ litT (\ _ -> mempty)          <+ addT (extractT t) (extractT t) mappend          <+ eseqT (extractT t) (extractT t) mappend-         <+ fail "allT failed" +  oneT t =  addT' (extractT t) (extractT t) (<<+)+         <+ eseqT' (extractT t) (extractT t) (<<+)+         <+ fail "oneT 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" +  oneR r =  addOneR (extractR r) (extractR r)+         <+ eseqOneR (extractR r) (extractR r)+         <+ fail "oneR failed"+ ---------------------------------------------------------------------------  instance Injection Cmd GenericExpr where@@ -103,23 +144,28 @@   retract (GCmd c) = Just c   retract _        = Nothing -instance Term Cmd where+instance Node Cmd where   type Generic Cmd = GenericExpr    numChildren (Seq _ _)    = 2-  numChildren (Assign _ _) = 2--instance Walker Context Maybe Cmd where+  numChildren (Assign _ _) = 1 -  childL 0 =  seqT exposeT idR (childL0of2 Seq)+instance Walker Context KureMonad Cmd where+  childL n = lens $+    case n of+      0 ->    seqT exposeT id (childL0of2 Seq)            <+ assignT exposeT (childL1of2 Assign)-  childL 1 =  seqT idR exposeT (childL1of2 Seq)-           <+ missingChildL 1-  childL n = missingChildL n+      1 ->    seqT id exposeT (childL1of2 Seq)+           <+ fail (missingChild n)+      _ -> fail (missingChild n)    allT t =  seqT (extractT t) (extractT t) mappend          <+ assignT (extractT t) (\ _ -> id) +  oneT t =  seqT' (extractT t) (extractT t) (<<+)+         <+ assignT (extractT t) (\ _ -> id)+         <+ fail "oneT failed"+   allR r =  seqAllR (extractR r) (extractR r)          <+ assignR (extractR r) @@ -127,11 +173,15 @@          <+ assignR (extractR r)          <+ fail "anyR failed" +  oneR r =  seqOneR (extractR r) (extractR r)+         <+ assignR (extractR r)+         <+ fail "oneR failed"+ --------------------------------------------------------------------------- -seqT' :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Cmd b+seqT' :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (KureMonad a1 -> KureMonad a2 -> KureMonad 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)+                                       Seq cm1 cm2 -> f (apply t1 (c @@ 0) cm1) (apply t2 (updateContextCmd cm1 c @@ 1) cm2)                                        _           -> fail "not a Seq"  seqT :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (a1 -> a2 -> b) -> TranslateE Cmd b@@ -143,11 +193,14 @@ seqAnyR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd seqAnyR r1 r2 = seqT' (attemptR r1) (attemptR r2) (attemptAny2 Seq) +seqOneR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd+seqOneR r1 r2 = seqT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 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+                                      Assign n e -> f n <$> apply t (c @@ 0) e                                       _          -> fail "not an Assign"  assignR :: RewriteE Expr -> RewriteE Cmd@@ -169,9 +222,9 @@  --------------------------------------------------------------------------- -addT' :: TranslateE Expr a1 -> TranslateE Expr a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Expr b+addT' :: TranslateE Expr a1 -> TranslateE Expr a2 -> (KureMonad a1 -> KureMonad a2 -> KureMonad 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)+                                       Add e1 e2 -> f (apply t1 (c @@ 0) e1) (apply t2 (c @@ 1) e2)                                        _         -> fail "not an Add"  addT :: TranslateE Expr a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b@@ -183,11 +236,14 @@ addAnyR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr addAnyR r1 r2 = addT' (attemptR r1) (attemptR r2) (attemptAny2 Add) +addOneR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr+addOneR r1 r2 = addT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 Add)+ --------------------------------------------------------------------------- -eseqT' :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Expr b+eseqT' :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (KureMonad a1 -> KureMonad a2 -> KureMonad 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)+                                        ESeq cm e1 -> f (apply t1 (c @@ 0) cm) (apply t2 (updateContextCmd cm c @@ 1) e1)                                         _          -> fail "not an ESeq"  eseqT :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b@@ -198,5 +254,8 @@  eseqAnyR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr eseqAnyR r1 r2 = eseqT' (attemptR r1) (attemptR r2) (attemptAny2 ESeq)++eseqOneR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr+eseqOneR r1 r2 = eseqT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 ESeq)  ---------------------------------------------------------------------------

@@ -1,21 +1,26 @@ module Fib.Examples where +import Prelude hiding (id , (.), snd)+import Control.Category+ import Language.KURE+import Language.KURE.Utilities(runKureMonad)  import Fib.AST import Fib.Kure  ----------------------------------------------------------------------- -applyFib :: RewriteA -> Arith -> Maybe Arith-applyFib e = apply e ()+applyFib :: RewriteA -> Arith -> Either String Arith+applyFib r = runKureMonad Right Left . apply r rootAbsPath  -----------------------------------------------------------------------  -- | 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+fibLitR = withPatFailMsg "fibLitR failed: not of form Fib (Lit n)" $+          do Fib (Lit n) <- id              case n of                0  ->  return (Lit 0)                1  ->  return (Lit 1)@@ -25,18 +30,21 @@  -- | Compute the addition of two literals. addLitR :: RewriteA-addLitR = do Add (Lit m) (Lit n) <- idR+addLitR = withPatFailMsg "addLitR failed" $+          do Add (Lit m) (Lit n) <- id              return (Lit (m + n))  -- | Compute the subtraction of two literals. subLitR :: RewriteA-subLitR = do Sub (Lit m) (Lit n) <- idR+subLitR = withPatFailMsg "subLitR failed" $+          do Sub (Lit m) (Lit n) <- id              return (Lit (m - n))  -----------------------------------------------------------------------  arithR :: RewriteA-arithR = addLitR >+> subLitR+arithR = setFailMsg "arithR failed" $+         addLitR >+> subLitR  anyAddR :: RewriteA anyAddR = anybuR addLitR@@ -47,6 +55,9 @@ anyArithR :: RewriteA anyArithR = anybuR arithR +allArithR :: RewriteA+allArithR = allbuR arithR+ evalR :: RewriteA evalR = innermostR (arithR >+> fibLitR) @@ -62,61 +73,76 @@ expr3 = 100 - Fib (3 + 7)  test1a :: Bool-test1a = applyFib anyAddR expr1+test1a = applyFib (allR addLitR) expr1          ==-         Just (10 - 5)+         Right (10 - 5)  test1b :: Bool-test1b = applyFib anySubR expr1+test1b = applyFib (alltdR addLitR) expr1          ==-         Nothing+         Left "alltdR failed: addLitR failed"  test1c :: Bool-test1c = applyFib anyArithR expr1+test1c = applyFib anyAddR expr1          ==-         Just 5+         Right (10 - 5)  test1d :: Bool-test1d = applyFib evalR expr1+test1d = applyFib anySubR expr1          ==-         Just 5+         Left "anybuR failed" +test1e :: Bool+test1e = applyFib anyArithR expr1+         ==+         Right 5++test1f :: Bool+test1f = applyFib evalR expr1+         ==+         Right 5+ test2a :: Bool test2a = applyFib fibLitR expr2          ==-         Just ((Fib (8 - 1)) + (Fib (8 - 2)))+         Right ((Fib (8 - 1)) + (Fib (8 - 2)))  test2b :: Bool test2b = applyFib (anytdR fibLitR) expr2          ==-         Just ((Fib (8 - 1)) + (Fib (8 - 2)))+         Right ((Fib (8 - 1)) + (Fib (8 - 2)))  test2c :: Bool test2c = applyFib evalR expr2          ==-         Just 21+         Right 21  test3a :: Bool test3a = applyFib anyArithR expr3          ==-         Just (100 - (Fib 10))+         Right (100 - (Fib 10))  test3b :: Bool test3b = applyFib (anyArithR >+> anyR fibLitR) expr3          ==-         Just (100 - ((Fib (10 - 1)) + (Fib (10 - 2))))+         Right (100 - ((Fib (10 - 1)) + (Fib (10 - 2))))  test3c :: Bool test3c = applyFib evalR expr3          ==-         Just 45+         Right 45 +test3d :: Bool+test3d = applyFib allArithR expr3+         ==+         Left "allbuR failed: allR failed: arithR failed"+ -----------------------------------------------------------------------  checkTests :: Bool-checkTests = and [ test1a, test1b, test1c, test1d-                 , test2a, test2b, test2c, test3a-                 , test3b, test3c+checkTests = and [ test1a, test1b, test1c, test1d, test1e, test1f+                 , test2a, test2b, test2c+                 , test3a, test3b, test3c, test3d                  ]  -----------------------------------------------------------------------

@@ -2,20 +2,19 @@  module Fib.Kure where -import Control.Applicative- import Language.KURE+import Language.KURE.Utilities(KureMonad,missingChild) 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+-- | For this simple example, the context is just an 'AbsolutePath', and 'Translate' always operates on 'Arith'.+type TranslateA b = Translate AbsolutePath KureMonad Arith b type RewriteA = TranslateA Arith  -------------------------------------------------------------------------------------- -instance Term Arith where+instance Node Arith where   type Generic Arith = Arith    numChildren (Lit _)   = 0@@ -23,20 +22,19 @@   numChildren (Sub _ _) = 2   numChildren (Fib _)   = 1 -instance Walker () Maybe Arith where+instance Walker AbsolutePath KureMonad 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+  childL n = lens $ translate $ \ c e ->+    do guardMsg (hasChild n e) (missingChild n)+       let c' = extendAbsPath n c+       case e of+         Add e1 e2  ->  case n of+                          0 -> return ((c',e1), \ e1' -> return (Add e1' e2))+                          1 -> return ((c',e2), \ e2' -> return (Add e1 e2'))+         Sub e1 e2  ->  case n of+                          0 -> return ((c',e1), \ e1' -> return (Sub e1' e2))+                          1 -> return ((c',e2), \ e2' -> return (Sub e1 e2'))+         Fib e1     ->  case n of+                          0 -> return ((c',e1), \ e1' -> return (Fib e1'))  --------------------------------------------------------------------------------------

@@ -1,13 +1,7 @@ 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@@ -19,49 +13,5 @@   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  -------------------------------------------------------------------------------

@@ -1,19 +1,21 @@ module Lam.Examples where +import Prelude hiding (id, (.))+ import Language.KURE  import Lam.AST import Lam.Kure  import Data.List (nub)-import Control.Monad (guard) import Control.Arrow+import Control.Category  ------------------------------------------------------------------------  freeVarsT :: TranslateExp [Name] freeVarsT = fmap nub $ crushbuT $ do (c, Var v) <- exposeT-                                     guard (v `notElem` c)+                                     guardM (v `freeIn` c)                                      return [v]  freeVars :: Exp -> [Name]@@ -21,7 +23,7 @@  -- Only works for lambdas, fails for all others alphaLam :: [Name] -> RewriteExp-alphaLam frees = do Lam v e <- idR+alphaLam frees = do Lam v e <- id                     v' <- constT $ freshName $ frees ++ v : freeVars e                     lamT (tryR $ substExp v (Var v')) (\ _ -> Lam v') @@ -31,31 +33,32 @@         -- 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+        rules_lam = do Lam n e <- id+                       guardM (n /= v)                              -- Rule 3+                       guardM (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+        rule_app = do App _ _ <- id                       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)+beta_reduce = withPatFailMsg "Cannot beta-reduce, not app-lambda." $+                do App (Lam v _) e2 <- id+                   pathT [0,0] (tryR $ substExp v e2)  eta_expand :: RewriteExp-eta_expand = rewrite $ \ c f -> do v <- freshName c+eta_expand = rewrite $ \ c f -> do v <- freshName (bindings 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."+eta_reduce = withPatFailMsg "Cannot eta-reduce, not lambda-app-var." $+               do Lam v1 (App f (Var v2)) <- id+                  guardMsg (v1 == v2) $ "Cannot eta-reduce, " ++ v1 ++ " /= " ++ v2+                  return f  -- This might not actually be normal order evaluation -- Contact the  KURE maintainer if you can correct this definition.@@ -63,7 +66,7 @@ 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.+-- Contact the KURE maintainer if you can correct this definition. applicative_order_eval :: RewriteExp applicative_order_eval = innermostR beta_reduce 

@@ -2,7 +2,11 @@  module Lam.Kure where +import Prelude hiding (id, (.))+ import Control.Applicative+import Control.Category+import Control.Monad  import Language.KURE import Language.KURE.Utilities@@ -11,15 +15,77 @@  ------------------------------------------------------------------------------- +data Context = Context AbsolutePath [Name] -- bound variable names++instance PathContext Context where+  contextPath (Context p _) = p++addBinding :: Name -> Context -> Context+addBinding v (Context p vs) = Context p (v:vs)++(@@) :: Context -> Int -> Context+(Context p vs) @@ n = Context (extendAbsPath n p) vs++initialContext :: Context+initialContext = Context rootAbsPath []++bindings :: Context -> [Name]+bindings (Context _ vs) = vs++boundIn :: Name -> Context -> Bool+boundIn v c = v `elem` bindings c++freeIn :: Name -> Context -> Bool+freeIn v c = not (v `boundIn` c)++-------------------------------------------------------------------------------++newtype LamM a = LamM {lamM :: Int -> (Int, Either String a)}++runLamM :: LamM a -> Either String a+runLamM m = snd (lamM m 0)++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)  -> lamM (gg a) n'+  fail msg = LamM (\ n -> (n, Left msg))++instance MonadCatch LamM where+  (LamM f) `catchM` g = LamM $ \ n -> case f n of+                                        (n', Left msg) -> lamM (g msg) n'+                                        (n', Right a)  -> (n', Right a)++instance Functor LamM where+  fmap = liftM++instance Applicative LamM where+  pure  = return+  (<*>) = ap++-------------------------------------------------------------------------------++suggestName :: LamM Name+suggestName = LamM (\n -> ((n+1), Right (show n)))++freshName :: [Name] -> LamM Name+freshName vs = do v <- suggestName+                  if v `elem` vs+                    then freshName vs+                    else return v++-------------------------------------------------------------------------------+ type TranslateExp b = Translate Context LamM Exp b type RewriteExp     = TranslateExp Exp  applyExp :: TranslateExp b -> Exp -> Either String b-applyExp f = runLamM . apply f []+applyExp f = runLamM . apply f initialContext  ------------------------------------------------------------------------------- -instance Term Exp where+instance Node Exp where    type Generic Exp = Exp  -- Exp is its own Generic     numChildren (Var _)   = 0@@ -27,13 +93,14 @@    numChildren (App _ _) = 2  instance Walker Context LamM Exp where-   childL n = case n of-                0 ->    appT exposeT idR (childL0of2 App)-                     <+ lamT exposeT (childL1of2 Lam)+   childL n = lens $+     case n of+       0 ->    appT exposeT id (childL0of2 App)+            <+ lamT exposeT (childL1of2 Lam) -                1 ->     appT idR exposeT (childL1of2 App)+       1 -> appT id exposeT (childL1of2 App) -                _ -> missingChildL n+       _ -> fail (missingChild n)  ------------------------------------------------------------------------------- @@ -49,7 +116,7 @@  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+                                  Lam v e1 -> f v <$> apply t (addBinding v c @@ 0) e1                                   _        -> fail "no match for Lam"  lamR :: RewriteExp -> RewriteExp@@ -59,7 +126,7 @@  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)+         App e1 e2 -> f (apply t1 (c @@ 0) e1) (apply t2 (c @@ 1) e2)          _         -> fail "no match for App"  appT :: TranslateExp a1 -> TranslateExp a2 -> (a1 -> a2 -> b) -> TranslateExp b

@@ -1,10 +1,10 @@ Name:                kure-Version:             2.0.0+Version:             2.2.0 Synopsis:            Combinators for Strategic Programming 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.+		     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.