kure 2.8.0 → 2.12.0

raw patch · 22 files changed

+453/−256 lines, 22 filesdep +ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Language/KURE/BiTranslate.hs +3/−2
• Language/KURE/Combinators.hs +1/−1
• Language/KURE/Combinators/Arrow.hs +10/−9
• Language/KURE/Combinators/Translate.hs +34/−12
• Language/KURE/ExtendableContext.hs +45/−0
• Language/KURE/Injection.hs +11/−6
• Language/KURE/Lens.hs +4/−3
• Language/KURE/MonadCatch.hs +16/−10
• Language/KURE/Path.hs +14/−17
• Language/KURE/Pathfinder.hs +109/−0
• Language/KURE/Translate.hs +25/−24
• Language/KURE/Walker.hs +34/−93
• examples/Expr/AST.hs +3/−0
• examples/Expr/Context.hs +22/−6
• examples/Expr/Examples.hs +45/−10
• examples/Expr/Kure.hs +32/−32
• examples/Fib/Kure.hs +7/−8
• examples/Lam/Context.hs +4/−4
• examples/Lam/Kure.hs +15/−15
• examples/Lam/Monad.hs +13/−1
• kure.cabal +5/−2

@@ -1,4 +1,4 @@-(c) 2006-2012 The University of Kansas+(c) 2006-2013 The University of Kansas All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,3 +1,4 @@+{-# Language InstanceSigs #-} -- | -- Module: Language.KURE.BiTranslate -- Copyright: (c) 2012--2013 The University of Kansas@@ -55,11 +56,11 @@ {-# INLINE invertBiT #-}  instance Monad m => Category (BiTranslate c m) where--- id :: BiTranslate c m a a+   id :: BiTranslate c m a a    id = bidirectional id id    {-# INLINE id #-} --- (.) :: BiTranslate c m b d -> BiTranslate c m a b -> BiTranslate c m a d+   (.) :: 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)    {-# INLINE (.) #-} 

@@ -8,7 +8,7 @@ -- Portability: ghc -- -- This module provides various monadic and arrow combinators that are useful when--- working with 'Translate's and 'Rewrite's.+-- working with 'Language.KURE.Translate.Translate's and 'Language.KURE.Translate.Rewrite's.  module Language.KURE.Combinators            (

@@ -12,6 +12,7 @@ module Language.KURE.Combinators.Arrow            ( -- * Arrow Routing              -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators.+             --   <http://conal.net/blog/posts/semantic-editor-combinators>              result            , argument            , toFst@@ -35,42 +36,42 @@  ------------------------------------------------------------------------------------------ --- | Apply a pure function to the result of an 'Arrow'.+-- | Apply a pure function to the result of an arrow. result :: Arrow bi => (b -> c) -> bi a b -> bi a c result f a = a >>^ f {-# INLINE result #-} --- | Apply a pure function to the argument to an 'Arrow'.+-- | Apply a pure function to the argument to an arrow. argument :: Arrow bi => (a -> b) -> bi b c -> bi a c argument f a = f ^>> a {-# INLINE argument #-} --- | Apply an 'Arrow' to the first element of a pair, discarding the second element.+-- | Apply an arrow to the first element of a pair, discarding the second element. toFst :: Arrow bi => bi a b -> bi (a,x) b toFst f = fst ^>> f {-# INLINE toFst #-} --- | Apply an 'Arrow' to the second element of a pair, discarding the first element.+-- | Apply an arrow to the second element of a pair, discarding the first element. toSnd :: Arrow bi => bi a b -> bi (x,a) b toSnd f = snd ^>> f {-# INLINE toSnd #-} --- | A pure 'Arrow' that swaps the elements of a pair.+-- | A pure arrow that swaps the elements of a pair. swap :: Arrow bi => bi (a,b) (b,a) swap = arr (\(a,b) -> (b,a)) {-# INLINE swap #-} --- | A pure 'Arrow' that duplicates its argument.+-- | A pure arrow that duplicates its argument. fork :: Arrow bi => bi a (a,a) fork = arr (\a -> (a,a)) {-# INLINE fork #-} --- | Tag the result of an 'Arrow' with its argument.+-- | Tag the result of an arrow with its argument. forkFirst :: Arrow bi => bi a b -> bi a (b,a) forkFirst sf = fork >>> first sf {-# INLINE forkFirst #-} --- | Tag the result of an 'Arrow' with its argument.+-- | Tag the result of an arrow with its argument. forkSecond :: Arrow bi => bi a b -> bi a (a,b) forkSecond sf = fork >>> second sf {-# INLINE forkSecond #-}@@ -87,7 +88,7 @@ serialise = foldr (>>>) id {-# INLINE serialise #-} --- | Apply a collection of 'Arrow's to the same input, combining their results in a monoid.+-- | Apply a collection of arrows to the same input, combining their results in a monoid. parallelise :: (Foldable f, Arrow bi, Monoid b) => f (bi a b) -> bi a b parallelise = foldr (\ f g -> (f &&& g) >>^ uncurry mappend) (constant mempty) {-# INLINE parallelise #-}

@@ -1,3 +1,4 @@+{-# Language InstanceSigs #-} -- | -- Module: Language.KURE.Combinators.Translate -- Copyright: (c) 2012--2013 The University of Kansas@@ -12,8 +13,10 @@ module Language.KURE.Combinators.Translate         ( -- * Translate Combinators           idR+        , successT         , contextT         , exposeT+        , liftContext         , readerT         , resultT         , catchesT@@ -27,8 +30,10 @@         , (>+>)         , repeatR         , acceptR+        , acceptWithFailMsgR         , accepterR         , changedR+        , changedByR         , sideEffectR           -- * Monad Transformers           -- ** anyR Support@@ -63,6 +68,11 @@ idR = id {-# INLINE idR #-} +-- | An always successful 'Translate'.+successT :: Monad m => Translate c m a ()+successT = return ()+{-# INLINE successT #-}+ -- | Extract the current context. contextT :: Monad m => Translate c m a c contextT = translate (\ c _ -> return c)@@ -73,6 +83,11 @@ exposeT = translate (curry return) {-# INLINE exposeT #-} +-- | Lift a 'Translate' to operate on a derived context.+liftContext :: (c -> c') -> Translate c' m a b -> Translate c m a b+liftContext f t = translate (apply t . f)+{-# INLINE liftContext #-}+ -- | Map a 'Translate' over a list. mapT :: (Traversable t, Monad m) => Translate c m a b -> Translate c m (t a) (t b) mapT t = translate (mapM . apply t)@@ -113,7 +128,7 @@ acceptWithFailMsgR p msg = readerT $ \ a -> if p a then id else fail msg {-# INLINE acceptWithFailMsgR #-} --- | Look at the argument to an 'Rewrite', and choose to be either the identity rewrite or a failure.+-- | Look at the argument to a 'Rewrite', and choose to be either 'idR' or a failure. acceptR :: Monad m => (a -> Bool) -> Rewrite c m a acceptR p = acceptWithFailMsgR p "acceptR: predicate failed" {-# INLINE acceptR #-}@@ -123,14 +138,21 @@ accepterR t = ifM t idR (fail "accepterR: predicate failed") {-# INLINE accepterR #-} --- | Catch a failing 'Category', making it into an identity.+-- | Catch a failing 'Rewrite', making it into an identity. tryR :: MonadCatch m => Rewrite c m a -> Rewrite c m a tryR r = r <+ id {-# INLINE tryR #-} +-- | Makes a 'Rewrite' fail if the result value and the argument value satisfy the equality predicate.+--   This is a generalisation of 'changedR'.+--   @changedR = changedByR ('==')@+changedByR :: MonadCatch m => (a -> a -> Bool) -> Rewrite c m a -> Rewrite c m a+changedByR p r = readerT (\ a -> r >>> acceptWithFailMsgR (not . p a) "changedByR: value is unchanged")+{-# INLINE changedByR #-}+ -- | Makes an 'Rewrite' fail if the result value equals the argument value. changedR :: (MonadCatch m, Eq a) => Rewrite c m a -> Rewrite c m a-changedR r = readerT (\ a -> r >>> acceptWithFailMsgR (/= a) "changedR: value is unchanged")+changedR = changedByR (==) {-# INLINE changedR #-}  -- | Repeat a 'Rewrite' until it fails, then return the result before the failure.@@ -145,7 +167,7 @@ catchesT = foldr (<+) (fail "catchesT failed") {-# INLINE catchesT #-} --- | An identity translation that resembles a monadic 'join'.+-- | An identity translation that resembles a monadic 'Control.Monad.join'. joinT :: Translate c m (m a) a joinT = contextfreeT id {-# INLINE joinT #-}@@ -182,22 +204,22 @@ {-# INLINE unAnyR #-}  instance Monad m => Monad (AnyR m) where--- return :: a -> AnyR m a+   return :: a -> AnyR m a    return = AnyR . return . PBool False    {-# INLINE return #-} --- fail :: String -> AnyR m a+   fail :: String -> AnyR m a    fail = AnyR . fail    {-# INLINE fail #-} --- (>>=) :: AnyR m a -> (a -> AnyR m d) -> AnyR m d+   (>>=) :: AnyR m a -> (a -> AnyR m d) -> AnyR m d    ma >>= f = AnyR $ do PBool b1 a <- unAnyR ma                         PBool b2 d <- unAnyR (f a)                         return (PBool (b1 || b2) d)    {-# INLINE (>>=) #-}  instance MonadCatch m => MonadCatch (AnyR m) where--- catchM :: AnyR m a -> (String -> AnyR m a) -> AnyR m a+   catchM :: AnyR m a -> (String -> AnyR m a) -> AnyR m a    catchM ma f = AnyR (unAnyR ma `catchM` (unAnyR . f))    {-# INLINE catchM #-} @@ -227,21 +249,21 @@ {-# INLINE unOneR #-}  instance Monad m => Monad (OneR m) where--- return :: a -> OneR m a+   return :: a -> OneR m a    return a = OneR (\ b -> return (PBool b a))    {-# INLINE return #-} --- fail :: String -> OneR m a+   fail :: String -> OneR m a    fail msg = OneR (\ _ -> fail msg)    {-# INLINE fail #-} --- (>>=) :: OneR m a -> (a -> OneR m d) -> OneR m d+   (>>=) :: OneR m a -> (a -> OneR m d) -> OneR m d    ma >>= f = OneR $ \ b1 -> do PBool b2 a <- unOneR ma b1                                 unOneR (f a) b2    {-# INLINE (>>=) #-}  instance MonadCatch m => MonadCatch (OneR m) where--- catchM :: OneR m a -> (String -> OneR m a) -> OneR m a+   catchM :: OneR m a -> (String -> OneR m a) -> OneR m a    catchM (OneR g) f = OneR (\ b -> g b `catchM` (($ b) . unOneR . f))    {-# INLINE catchM #-} 

@@ -0,0 +1,45 @@+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+-- |+-- Module: Language.KURE.ExtendableContext+-- Copyright: (c) 2012--2013 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides a utility data type for extending an existing context with extra information.+-- The idea is that, after defining class instances for any user-specific contextual operations, it can be used for any ad-hoc context extensions.+-- See the treatment of 'ExtendPath' as an example.++module Language.KURE.ExtendableContext+        (+        -- * Extending Contexts+          ExtendContext+        , extendContext+        , baseContext+        , extraContext+) where++import Language.KURE.Path++------------------------------------------------------------------------------------------------++-- | A context transformer, for augmenting a context with additional information.+data ExtendContext c e = ExtendContext+                           { -- | Retrieve the base context (without the extra information).+                             baseContext   :: c+                             -- | Retrieve the extra contextual information.+                           , extraContext  :: e+                           }++-- | Extend a context with some additional information.+extendContext :: e -> c -> ExtendContext c e+extendContext e c = ExtendContext c e++-- | Both components of the context are updated with the crumb.+instance (ExtendPath c crumb, ExtendPath e crumb) => ExtendPath (ExtendContext c e) crumb where+   (@@) :: ExtendContext c e -> crumb -> ExtendContext c e+   (ExtendContext c e) @@ cr = ExtendContext (c @@ cr) (e @@ cr)++------------------------------------------------------------------------------------------------

@@ -1,5 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module: Language.KURE.Injection -- Copyright: (c) 2012--2013 The University of Kansas@@ -49,16 +48,22 @@  -- | There is an identity injection for all types. instance Injection a a where+  inject :: a -> a+  inject = id   {-# INLINE inject #-}-  inject  = id-  {-# INLINE project #-}++  project :: a -> Maybe a   project = Just+  {-# INLINE project #-}  instance Injection a (Maybe a) where-  {-# INLINE inject #-}+  inject :: a -> Maybe a   inject  = Just-  {-# INLINE project #-}+  {-# INLINE inject #-}++  project :: Maybe a -> Maybe a   project = id+  {-# INLINE project #-}  ------------------------------------------------------------------------------- 

@@ -1,3 +1,4 @@+{-# Language InstanceSigs #-} -- | -- Module: Language.KURE.Lens -- Copyright: (c) 2012--2013 The University of Kansas@@ -69,11 +70,11 @@  instance Monad m => Category (Lens c m) where --- id :: Lens c m a a+   id :: Lens c m a a    id = lens $ translate $ \ c a -> return ((c,a), return)    {-# INLINE id #-} --- (.) :: Lens c m b d -> Lens c m a b -> Lens c m a d+   (.) :: 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)@@ -86,7 +87,7 @@  -- | 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.+--   (as by then it is too late to use an alternative 'Lens').  This means that, in theory, a use of 'catchL' could cause a succeeding 'Lens' application to fail. --   But provided 'lens' is used correctly, this should never happen. catchL :: MonadCatch m => Lens c m a b -> (String -> Lens c m a b) -> Lens c m a b l1 `catchL` l2 = lens (attemptM (focusR l1 idR) >>= either (lensT . l2) (const (lensT l1)))

@@ -1,3 +1,4 @@+{-# Language InstanceSigs #-} -- | -- Module: Language.KURE.MonadCatch -- Copyright: (c) 2012--2013 The University of Kansas@@ -16,6 +17,7 @@            , KureM            , runKureM            , fromKureM+           , liftKureM              -- ** Combinators            , (<+)            , catchesM@@ -58,8 +60,7 @@  -- | 'KureM' is the minimal structure that can be an instance of 'MonadCatch'. --   The KURE user is free to either use 'KureM' or provide their own monad.---   'KureM' is essentially the same as ('Either' 'String' @a@), except that the 'fail' method produces an error in the monad,---   rather than invoking 'error'.+--   'KureM' is essentially the same as 'Either' 'String', except that it supports a 'MonadCatch' instance which 'Either' 'String' does not (because its 'fail' method calls 'error') --   A major advantage of this is that monadic pattern match failures are caught safely. data KureM a = Failure String | Success a deriving (Eq, Show) @@ -74,37 +75,42 @@ fromKureM = runKureM id {-# INLINE fromKureM #-} +-- | Lift a 'KureM' computation to any other monad.+liftKureM :: Monad m => KureM a -> m a+liftKureM = runKureM return fail+{-# INLINE liftKureM #-}+ instance Monad KureM where--- return :: a -> KureM a+   return :: a -> KureM a    return = Success    {-# INLINE return #-} --- (>>=) :: KureM a -> (a -> KureM b) -> KureM b+   (>>=) :: KureM a -> (a -> KureM b) -> KureM b    (Success a)   >>= f = f a    (Failure msg) >>= _ = Failure msg    {-# INLINE (>>=) #-} --- fail :: String -> KureM a+   fail :: String -> KureM a    fail = Failure    {-# INLINE fail #-}  instance MonadCatch KureM where--- catchM :: KureM a -> (String -> KureM a) -> KureM a+   catchM :: KureM a -> (String -> KureM a) -> KureM a    (Success a)   `catchM` _ = Success a    (Failure msg) `catchM` f = f msg    {-# INLINE catchM #-}  instance Functor KureM where--- fmap :: (a -> b) -> KureM a -> KureM b+   fmap :: (a -> b) -> KureM a -> KureM b    fmap = liftM    {-# INLINE fmap #-}  instance Applicative KureM where--- pure :: a -> KureM a+   pure :: a -> KureM a    pure = return    {-# INLINE pure #-} --- (<*>) :: KureM (a -> b) -> KureM a -> KureM b+   (<*>) :: KureM (a -> b) -> KureM a -> KureM b    (<*>) = ap    {-# INLINE (<*>) #-} @@ -140,7 +146,7 @@ testM ma = liftM (const True) ma <+ return False {-# INLINE testM #-} --- | Fail if the 'Monad' succeeds; succeed with @()@ if it fails.+-- | Fail if the monadic computation succeeds; succeed with @()@ if it fails. notM :: MonadCatch m => m a -> m () notM ma = ifM (testM ma) (fail "notM of success") (return ()) {-# INLINE notM #-}

@@ -1,5 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}-+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -- | -- Module: Language.KURE.Path -- Copyright: (c) 2012--2013 The University of Kansas@@ -22,17 +21,17 @@           -- ** Relative Paths          Path-       , rootPathT          -- ** Snoc Paths        , SnocPath(..)+       , ExtendPath(..)        , snocPathToPath        , pathToSnocPath        , lastCrumb-         -- ** Absolute Paths+         -- ** Absolute and Local Paths+       , LocalPath        , AbsolutePath-       , lastCrumbT-       , ExtendPath(..)        , ReadPath(..)+       , lastCrumbT        , absPathT        ) where@@ -57,10 +56,10 @@ newtype SnocPath crumb = SnocPath [crumb] deriving Eq  instance Monoid (SnocPath crumb) where--- mempty :: SnocPath crumb+   mempty :: SnocPath crumb    mempty = SnocPath [] --- mappend :: SnocPath crumb -> SnocPath crumb -> SnocPath crumb+   mappend :: SnocPath crumb -> SnocPath crumb -> SnocPath crumb    mappend (SnocPath p1) (SnocPath p2) = SnocPath (p2 ++ p1)  -- | Convert a 'Path' to a 'SnocPath'.  O(n).@@ -74,7 +73,7 @@ {-# INLINE snocPathToPath #-}  instance Show crumb => Show (SnocPath crumb) where--- show :: SnocPath crumb -> String+   show :: SnocPath crumb -> String    show = show . snocPathToPath    {-# INLINE show #-} @@ -88,7 +87,7 @@ -- | A class of things that can be extended by crumbs. --   Typically, @c@ is a context type. --   The typical use is to extend an 'AbsolutePath' stored in the context (during tree traversal).---   Note however, that if an 'AbsolutePath' is not stored in the context, an instance can still be declared with @(\@\@ cr)@ as an identity operation.+--   Note however, that if an 'AbsolutePath' is not stored in the context, an instance can still be declared with @('@@' crumb)@ as an identity operation. class ExtendPath c crumb | c -> crumb where   -- | Extend the current 'AbsolutePath' by one crumb.   (@@) :: c -> crumb -> c@@ -96,6 +95,9 @@ -- | A 'SnocPath' from the root. type AbsolutePath = SnocPath +-- | A 'SnocPath' from a local origin.+type LocalPath = SnocPath+ -- | A class for contexts that store the current 'AbsolutePath', allowing transformations to depend upon it. class ReadPath c crumb | c -> crumb where   -- | Read the current absolute path.@@ -106,11 +108,6 @@ absPathT = contextT >>^ absPath {-# INLINE absPathT #-} --- | Retrieve the 'Path' from the root to the current node.-rootPathT :: (ReadPath c crumb, Monad m) => Translate c m a (Path crumb)-rootPathT = absPathT >>^ snocPathToPath-{-# INLINE rootPathT #-}- -- | Lifted version of 'lastCrumb'. lastCrumbT :: (ReadPath c crumb, Monad m) => Translate c m a crumb lastCrumbT = contextonlyT (projectWithFailMsgM (fail "lastCrumbT failed: at the root, no crumbs yet.") . lastCrumb . absPath)@@ -120,13 +117,13 @@  -- | Any 'SnocPath' can be extended. instance ExtendPath (SnocPath crumb) crumb where--- (@@) :: SnocPath crumb -> crumb -> SnocPath crumb+   (@@) :: SnocPath crumb -> crumb -> SnocPath crumb    (SnocPath crs) @@ cr = SnocPath (cr:crs)    {-# INLINE (@@) #-}  -- | The simplest instance of 'ReadPath' is 'AbsolutePath' itself. instance ReadPath (AbsolutePath crumb) crumb where--- absPath :: AbsolutePath crumb -> AbsolutePath crumb+   absPath :: AbsolutePath crumb -> AbsolutePath crumb    absPath = id    {-# INLINE absPath #-} 

@@ -0,0 +1,109 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}++-- |+-- Module: Language.KURE.Pathfinder+-- Copyright: (c) 2012--2013 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides combinators to find 'LocalPath's sub-nodes specified by a predicate.++module Language.KURE.Pathfinder+        (+        -- * Finding Local Paths+        -- ** Context Transformers+        -- | To find a 'LocalPath' to a node that satisfies a predicate, use @'withLocalPathT' (tt ('acceptLocalPathT' q))@,+        --   where @q@ is a translation returning 'Bool', and @tt@ is a traversal strategy, such as 'collectT' or 'onetdT'.+        --   This will handle the tracking of the local path.+        --   See the example pathfinders below.+          WithLocalPath+        , withLocalPathT+        , exposeLocalPathT+        , acceptLocalPathT+        -- ** Example Pathfinders+        , pathsToT+        , onePathToT+        , oneNonEmptyPathToT+        , prunePathsToT+        , uniquePathToT+        , uniquePrunePathToT+) where++import Control.Category hiding ((.))+import Control.Arrow+import Data.Monoid (mempty)++import Language.KURE.MonadCatch+import Language.KURE.Translate+import Language.KURE.Combinators.Translate+import Language.KURE.Path+import Language.KURE.Walker+import Language.KURE.ExtendableContext++-------------------------------------------------------------------------------++-- | A context transformer that adds a 'LocalPath' (from the current node) to the context.+type WithLocalPath c crumb = ExtendContext c (LocalPath crumb)++-- | Apply a translation that stores a 'LocalPath' in the context (starting at the current node).+withLocalPathT :: Translate (WithLocalPath c crumb) m a b -> Translate c m a b+withLocalPathT = liftContext (extendContext mempty)+{-# INLINE withLocalPathT #-}++-- | Extract the current 'LocalPath' from the context.+exposeLocalPathT :: Monad m => Translate (WithLocalPath c crumb) m a (LocalPath crumb)+exposeLocalPathT = contextT >>^ extraContext+{-# INLINE exposeLocalPathT #-}++-- | Return the current 'LocalPath' if the predicate translation succeeds.+acceptLocalPathT :: Monad m => Translate c m g Bool -> Translate (WithLocalPath c crumb) m g (LocalPath crumb)+acceptLocalPathT q = accepterR (liftContext baseContext q) >>> exposeLocalPathT+{-# INLINE acceptLocalPathT #-}++-------------------------------------------------------------------------------++-- | Find the 'LocalPath's to every node that satisfies the predicate.+pathsToT :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Translate c m g Bool -> Translate c m g [LocalPath crumb]+pathsToT q = withLocalPathT (collectT $ acceptLocalPathT q)+{-# INLINE pathsToT #-}++-- | Find the 'LocalPath's to every node that satisfies the predicate, ignoring nodes below successes.+prunePathsToT :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Translate c m g Bool -> Translate c m g [LocalPath crumb]+prunePathsToT q = withLocalPathT (collectPruneT $ acceptLocalPathT q)+{-# INLINE prunePathsToT #-}++-- | Find the 'LocalPath' to the first node that satisfies the predicate (in a pre-order traversal).+onePathToT :: forall c crumb g m. (Walker (WithLocalPath c crumb) g, MonadCatch m) => Translate c m g Bool -> Translate c m g (LocalPath crumb)+onePathToT q = setFailMsg "No matching nodes found." $+               withLocalPathT (onetdT $ acceptLocalPathT q)+{-# INLINE onePathToT #-}++-- | Find the 'LocalPath' to the first descendent node that satisfies the predicate (in a pre-order traversal).+oneNonEmptyPathToT :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Translate c m g Bool -> Translate c m g (LocalPath crumb)+oneNonEmptyPathToT q = setFailMsg "No matching nodes found." $+                       withLocalPathT (oneT $ onetdT $ acceptLocalPathT q)+{-# INLINE oneNonEmptyPathToT #-}+++-- local function used by uniquePathToT and uniquePrunePathToT+requireUniquePath :: Monad m => Translate c m [LocalPath crumb] (LocalPath crumb)+requireUniquePath = contextfreeT $ \ ps -> case ps of+                                             []  -> fail "No matching nodes found."+                                             [p] -> return p+                                             _   -> fail $ "Ambiguous: " ++ show (length ps) ++ " matching nodes found."+{-# INLINE requireUniquePath #-}++-- | Find the 'LocalPath' to the node that satisfies the predicate, failing if that does not uniquely identify a node.+uniquePathToT :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Translate c m g Bool -> Translate c m g (LocalPath crumb)+uniquePathToT q = pathsToT q >>> requireUniquePath+{-# INLINE uniquePathToT #-}++-- | Build a 'LocalPath' to the node that satisfies the predicate, failing if that does not uniquely identify a node (ignoring nodes below successes).+uniquePrunePathToT :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Translate c m g Bool -> Translate c m g (LocalPath crumb)+uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath+{-# INLINE uniquePrunePathToT #-}++-------------------------------------------------------------------------------

@@ -1,3 +1,4 @@+{-# Language InstanceSigs #-} -- | -- Module: Language.KURE.Translate -- Copyright: (c) 2012--2013 The University of Kansas@@ -7,7 +8,7 @@ -- Stability: beta -- Portability: ghc ----- This module defines the main KURE types: 'Translate' and 'Rewrite'.+-- This module defines 'Translate' and 'Rewrite', the main KURE types. -- 'Rewrite' is just a special case of 'Translate', and so any function that operates on 'Translate' is also -- applicable to 'Rewrite'. --@@ -81,63 +82,63 @@ -- | Lifting through a Reader transformer, where (c,a) is the read-only environment. instance Functor m => Functor (Translate c m a) where --- fmap :: (b -> d) -> Translate c m a b -> Translate c m a d+   fmap :: (b -> d) -> Translate c m a b -> Translate c m a d    fmap f t = translate (\ c -> fmap f . apply t c)    {-# INLINE fmap #-}  -- | Lifting through a Reader transformer, where (c,a) is the read-only environment. instance Applicative m => Applicative (Translate c m a) where --- pure :: b -> Translate c m a b+   pure :: b -> Translate c m a b    pure = constT . pure    {-# INLINE pure #-} --- (<*>) :: Translate c m a (b -> d) -> Translate c m a b -> Translate c m a d+   (<*>) :: Translate c m a (b -> d) -> Translate c m a b -> Translate c m a d    tf <*> tb = translate (\ c a -> apply tf c a <*> apply tb c a)    {-# INLINE (<*>) #-}  -- | Lifting through a Reader transformer, where (c,a) is the read-only environment. instance Alternative m => Alternative (Translate c m a) where --- empty :: Translate c m a b+   empty :: Translate c m a b    empty = constT empty    {-# INLINE empty #-} --- (<|>) :: Translate c m a b -> Translate c m a b -> Translate c m a b+   (<|>) :: Translate c m a b -> Translate c m a b -> Translate c m a b    t1 <|> t2 = translate (\ c a -> apply t1 c a <|> apply t2 c a)    {-# INLINE (<|>) #-}  -- | Lifting through a Reader transformer, where (c,a) is the read-only environment. instance Monad m => Monad (Translate c m a) where --- return :: b -> Translate c m a b+   return :: b -> Translate c m a b    return = constT . return    {-# INLINE return #-} --- (>>=) :: Translate c m a b -> (b -> Translate c m a d) -> Translate c m a d+   (>>=) :: Translate c m a b -> (b -> Translate c m a d) -> Translate c m a d    t >>= f = translate $ \ c a -> do b <- apply t c a                                      apply (f b) c a    {-# INLINE (>>=) #-} --- fail :: String -> Translate c m a b+   fail :: String -> Translate c m a b    fail = constT . fail    {-# INLINE 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 :: 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    {-# INLINE catchM #-}  -- | Lifting through a Reader transformer, where (c,a) is the read-only environment. instance MonadPlus m => MonadPlus (Translate c m a) where --- mzero :: Translate c m a b+   mzero :: Translate c m a b    mzero = constT mzero    {-# INLINE mzero #-} --- mplus :: Translate c m a b -> Translate c m a b -> Translate c m a b+   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    {-# INLINE mplus #-} @@ -146,11 +147,11 @@ -- | The 'Kleisli' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. instance Monad m => Category (Translate c m) where --- id :: Translate c m a a+   id :: Translate c m a a    id = contextfreeT return    {-# INLINE id #-} --- (.) :: Translate c m b d -> Translate c m a b -> Translate c m a d+   (.) :: 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)    {-# INLINE (.) #-} @@ -158,44 +159,44 @@ -- | 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 :: (a -> b) -> Translate c m a b    arr f = contextfreeT (return . f)    {-# INLINE arr #-} --- first :: Translate c m 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)    {-# INLINE first #-} --- second :: Translate c m a b -> Translate c m (z,a) (z,b)+   second :: Translate c m a b -> Translate c m (z,a) (z,b)    second t = translate $ \ c (z,a) -> liftM (\ b -> (z,b)) (apply t c a)    {-# INLINE second #-} --- (***) :: Translate c m a1 b1 -> Translate c m a2 b2 -> Translate c m (a1,a2) (b1,b2)+   (***) :: Translate c m a1 b1 -> Translate c m a2 b2 -> Translate c m (a1,a2) (b1,b2)    t1 *** t2 = translate $ \ c (a,b) -> liftM2 (,) (apply t1 c a) (apply t2 c b)    {-# INLINE (***) #-} --- (&&&) :: Translate c m a b1 -> Translate c m a b2 -> Translate c m a (b1,b2)+   (&&&) :: Translate c m a b1 -> Translate c m a b2 -> Translate c m a (b1,b2)    t1 &&& t2 = translate $ \ c a -> liftM2 (,) (apply t1 c a) (apply t2 c a)    {-# INLINE (&&&) #-}  -- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. instance MonadPlus m => ArrowZero (Translate c m) where --- zeroArrow :: Translate c m a b+   zeroArrow :: Translate c m a b    zeroArrow = mzero    {-# INLINE zeroArrow #-}  -- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. instance MonadPlus m => ArrowPlus (Translate c m) where --- (<+>) :: Translate c m a b -> Translate c m a b -> Translate c m a b+   (<+>) :: Translate c m a b -> Translate c m a b -> Translate c m a b    (<+>) = mplus    {-# INLINE (<+>) #-}  -- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. instance Monad m => ArrowApply (Translate c m) where --- app :: Translate c m (Translate c m a b, a) b+   app :: Translate c m (Translate c m a b, a) b    app = translate (\ c (t,a) -> apply t c a)    {-# INLINE app #-} @@ -204,11 +205,11 @@ -- | Lifting through the 'Monad' and a Reader transformer, where (c,a) is the read-only environment. instance (Monad m, Monoid b) => Monoid (Translate c m a b) where --- mempty :: Translate c m a b+   mempty :: Translate c m a b    mempty = return mempty    {-# INLINE mempty #-} --- mappend :: Translate c m a b -> Translate c m a b -> Translate c m a b+   mappend :: Translate c m a b -> Translate c m a b -> Translate c m a b    mappend = liftM2 mappend    {-# INLINE mappend #-} 

@@ -1,5 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts #-}-+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts #-} -- | -- Module: Language.KURE.Walker -- Copyright: (c) 2012--2013 The University of Kansas@@ -59,24 +58,16 @@         , summandIsTypeT          -- * Paths-        -- ** Path-based Translations-        , pathsToT-        , onePathToT-        , oneNonEmptyPathToT-        , prunePathsToT-        , uniquePathToT-        , uniquePrunePathToT-         -- ** Building Lenses from Paths         , pathL+        , localPathL         , exhaustPathL         , repeatPathL-        , rootL-         -- ** Applying transformations at the end of Paths         , pathR         , pathT-+        , localPathR+        , localPathT         -- ** Testing Paths         , testPathT ) where@@ -163,14 +154,14 @@ -- | Fold a tree in a top-down manner, using a single 'Translate' for each node. foldtdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b foldtdT t = prefixFailMsg "foldtdT failed: " $-            let go = t `mappend` allT go+            let go = t <> allT go              in go {-# INLINE foldtdT #-}  -- | Fold a tree in a bottom-up manner, using a single 'Translate' for each node. foldbuT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b foldbuT t = prefixFailMsg "foldbuT failed: " $-            let go = allT go `mappend` t+            let go = allT go <> t              in go {-# INLINE foldbuT #-} @@ -291,66 +282,6 @@  ------------------------------------------------------------------------------- --- Apply a local Translate, using only a local path as context.-applySnocPathT :: Translate (SnocPath crumb) m a b -> Translate c m a b-applySnocPathT t = contextfreeT (apply t mempty)----- | Find the 'Path's to every node that satisfies the predicate.-pathsToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path crumb]-pathsToT q = applySnocPathT pathsToT' >>^ map snocPathToPath-  where-    pathsToT' :: Translate (SnocPath crumb) m g [SnocPath crumb]-    pathsToT' =  collectT (acceptR q >>> contextT)-    {-# INLINE pathsToT' #-}-{-# INLINE pathsToT #-}---- | Find the 'Path's to every node that satisfies the predicate, ignoring nodes below successes.-prunePathsToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path crumb]-prunePathsToT q = applySnocPathT prunePathsToT' >>^ map snocPathToPath-  where-    prunePathsToT' :: Translate (SnocPath crumb) m g [SnocPath crumb]-    prunePathsToT' =  collectPruneT (acceptR q >>> contextT)-    {-# INLINE prunePathsToT' #-}-{-# INLINE prunePathsToT #-}----- | Find the 'Path' to the first node that satisfies the predicate (in a pre-order traversal).-onePathToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)-onePathToT q = applySnocPathT onePathToT' >>^ snocPathToPath-  where-    onePathToT' :: (Walker (SnocPath crumb) g, MonadCatch m) => Translate (SnocPath crumb) m g (SnocPath crumb)-    onePathToT' =  setFailMsg "No matching nodes found." $-                   onetdT (acceptR q >>> contextT)-    {-# INLINE onePathToT' #-}-{-# INLINE onePathToT #-}---- | Find the 'Path' to the first descendent node that satisfies the predicate (in a pre-order traversal).-oneNonEmptyPathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)-oneNonEmptyPathToT q = applySnocPathT $ oneT (lastCrumbT &&& onePathToT q >>^ uncurry (:))-{-# INLINE oneNonEmptyPathToT #-}----- local function used by uniquePathToT and uniquePrunePathToT-requireUniquePath :: Monad m => Translate c m [Path crumb] (Path crumb)-requireUniquePath = contextfreeT $ \ ps -> case ps of-                                             []  -> fail "No matching nodes found."-                                             [p] -> return p-                                             _   -> fail $ "Ambiguous: " ++ show (length ps) ++ " matching nodes found."-{-# INLINE requireUniquePath #-}---- | Find the 'Path' to the node that satisfies the predicate, failing if that does not uniquely identify a node.-uniquePathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)-uniquePathToT q = pathsToT q >>> requireUniquePath-{-# INLINE uniquePathToT #-}---- | Build a 'Path' to the node that satisfies the predicate, failing if that does not uniquely identify a node (ignoring nodes below successes).-uniquePrunePathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)-uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath-{-# INLINE uniquePrunePathToT #-}---------------------------------------------------------------------------------- tryL :: MonadCatch m => Lens c m g g -> Lens c m g g tryL l = l `catchL` (\ _ -> id) {-# INLINE tryL #-}@@ -360,6 +291,11 @@ pathL = serialise . map childL {-# INLINE pathL #-} +-- | Build a 'Lens' from the root to a point specified by a 'LocalPath'.+localPathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => LocalPath crumb -> Lens c m g g+localPathL = pathL . snocPathToPath+{-# INLINE localPathL #-}+ -- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed. exhaustPathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Lens c m g g exhaustPathL = foldr (\ n l -> tryL (childL n >>> l)) id@@ -371,11 +307,6 @@                  in go {-# INLINE repeatPathL #-} --- | Build a 'Lens' from the root to a point specified by an 'AbsolutePath'.-rootL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => AbsolutePath crumb -> Lens c m g g-rootL = pathL . snocPathToPath-{-# INLINE rootL #-}- -------------------------------------------------------------------------------  -- | Apply a 'Rewrite' at a point specified by a 'Path'.@@ -388,6 +319,16 @@ pathT = focusT . pathL {-# INLINE pathT #-} +-- | Apply a 'Rewrite' at a point specified by a 'LocalPath'.+localPathR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => LocalPath crumb -> Rewrite c m g -> Rewrite c m g+localPathR = focusR . localPathL+{-# INLINE localPathR #-}++-- | Apply a 'Translate' at a point specified by a 'LocalPath'.+localPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => LocalPath crumb -> Translate c m g b -> Translate c m g b+localPathT = focusT . localPathL+{-# INLINE localPathT #-}+ -------------------------------------------------------------------------------  -- | Check if it is possible to construct a 'Lens' along this path from the current node.@@ -462,22 +403,22 @@ {-# INLINE unAllT #-}  instance (Monoid w, Monad m) => Monad (AllT w m) where--- return :: a -> AllT w m a+   return :: a -> AllT w m a    return a = AllT $ return (P a mempty)    {-# INLINE return #-} --- fail :: String -> AllT w m a+   fail :: String -> AllT w m a    fail = AllT . fail    {-# INLINE fail #-} --- (>>=) :: AllT w m a -> (a -> AllT w m d) -> AllT w m d+   (>>=) :: AllT w m a -> (a -> AllT w m d) -> AllT w m d    ma >>= f = AllT $ do P a w1 <- unAllT ma                         P d w2 <- unAllT (f a)                         return (P d (w1 <> w2))    {-# INLINE (>>=) #-}  instance (Monoid w, MonadCatch m) => MonadCatch (AllT w m) where--- catchM :: AllT w m a -> (String -> AllT w m a) -> AllT w m a+   catchM :: AllT w m a -> (String -> AllT w m a) -> AllT w m a    catchM (AllT ma) f = AllT $ ma `catchM` (unAllT . f)    {-# INLINE catchM #-} @@ -506,21 +447,21 @@ {-# INLINE unOneT #-}  instance Monad m => Monad (OneT w m) where--- return :: a -> OneT w m a+   return :: a -> OneT w m a    return a = OneT $ \ mw -> return (P a mw)    {-# INLINE return #-} --- fail :: String -> OneT w m a+   fail :: String -> OneT w m a    fail msg = OneT (\ _ -> fail msg)    {-# INLINE fail #-} --- (>>=) :: OneT w m a -> (a -> OneT w m d) -> OneT w m d+   (>>=) :: OneT w m a -> (a -> OneT w m d) -> OneT w m d    ma >>= f = OneT $ do \ mw1 -> do P a mw2 <- unOneT ma mw1                                     unOneT (f a) mw2    {-# INLINE (>>=) #-}  instance MonadCatch m => MonadCatch (OneT w m) where--- catchM :: OneT w m a -> (String -> OneT w m a) -> OneT w m a+   catchM :: OneT w m a -> (String -> OneT w m a) -> OneT w m a    catchM (OneT g) f = OneT $ \ mw -> g mw `catchM` (($ mw) . unOneT . f)    {-# INLINE catchM #-} @@ -552,22 +493,22 @@ {-# INLINE getChildSecond #-}  instance Monad (GetChild c g) where--- return :: a -> GetChild c g a+   return :: a -> GetChild c g a    return a = GetChild (return a) Nothing    {-# INLINE return #-} --- fail :: String -> GetChild c g a+   fail :: String -> GetChild c g a    fail msg = GetChild (fail msg) Nothing    {-# INLINE fail #-} --- (>>=) :: GetChild c g a -> (a -> GetChild c g b) -> GetChild c g b+   (>>=) :: GetChild c g a -> (a -> GetChild c g b) -> GetChild c g b    (GetChild kma mcg) >>= k = runKureM (\ a   -> getChildSecond (mplus mcg) (k a))                                        (\ msg -> GetChild (fail msg) mcg)                                        kma    {-# INLINE (>>=) #-}  instance MonadCatch (GetChild c g) where--- catchM :: GetChild c g a -> (String -> GetChild c g a) -> GetChild c g a+   catchM :: GetChild c g a -> (String -> GetChild c g a) -> GetChild c g a    gc@(GetChild kma mcg) `catchM` k = runKureM (\ _   -> gc)                                                (\ msg -> getChildSecond (mplus mcg) (k msg))                                                kma@@ -597,7 +538,7 @@ {-# INLINE wrapSetChild #-}  unwrapSetChild :: Monad m => Rewrite c SetChild g -> Rewrite c m g-unwrapSetChild = resultT (runKureM return fail)+unwrapSetChild = resultT liftKureM {-# INLINE unwrapSetChild #-}  setChild :: (ReadPath c crumb, Eq crumb, Walker c g, Monad m) => crumb -> g -> Rewrite c m g

@@ -1,3 +1,4 @@+{-# Language InstanceSigs #-} module Expr.AST where  -----------------------------------------------------------------@@ -11,10 +12,12 @@             deriving Eq  instance Show Cmd where+  show :: Cmd -> String   show (Seq c1 c2) = show c1 ++ " ; " ++ show c2   show (Assign n e) = n ++ " := " ++ show e  instance Show Expr where+  show :: Expr -> String   show (Var n)     = n   show (Lit n)     = show n   show (Add e1 e2) = "(" ++ show e1 ++ " + " ++ show e2 ++ ")"

@@ -1,10 +1,11 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses #-}  module Expr.Context where  import Data.Monoid (mempty)  import Language.KURE+import Language.KURE.ExtendableContext  import Expr.AST @@ -14,19 +15,34 @@                                                         -- We assume no shadowing in the language.  instance ExtendPath Context Int where--- (@@) :: Context -> Int -> Context+   (@@) :: Context -> Int -> Context    (Context p defs) @@ n = Context (p @@ n) defs  instance ReadPath Context Int where--- absPath :: Context -> AbsolutePath+   absPath :: Context -> AbsolutePath Int    absPath (Context p _) = p -addDef :: Name -> Expr -> Context -> Context-addDef v e (Context p defs) = Context p ((v,e):defs)+class AddDef c where+  addDef :: Name -> Expr -> c -> c -updateContextCmd :: Cmd -> Context -> Context+updateContextCmd :: AddDef c => Cmd -> c -> c updateContextCmd (Seq c1 c2)  = updateContextCmd c2 . updateContextCmd c1 updateContextCmd (Assign v e) = (addDef v e)++instance AddDef (SnocPath crumb) where+   addDef :: Name -> Expr -> SnocPath crumb -> SnocPath crumb+   addDef _ _ = id++instance AddDef Context where+   addDef :: Name -> Expr -> Context -> Context+   addDef v e (Context p defs) = Context p ((v,e):defs)++instance (AddDef c, AddDef e) => AddDef (ExtendContext c e) where+   addDef :: Name -> Expr -> ExtendContext c e -> ExtendContext c e+   addDef v e c = c+                   { baseContext  = addDef v e (baseContext c)+                   , extraContext = addDef v e (extraContext c)+                   }  initialContext :: Context initialContext = Context mempty []

@@ -1,6 +1,10 @@ module Expr.Examples where +import Data.Monoid (mempty)+import Control.Arrow (arr)+ import Language.KURE+import Language.KURE.Pathfinder  import Expr.AST import Expr.Context@@ -26,6 +30,14 @@ inlineGR :: RewriteE Generic inlineGR = promoteR inlineR +isAssign :: Generic -> Bool+isAssign (GCmd Assign{}) = True+isAssign _               = False++isESeq :: Generic -> Bool+isESeq (GExpr ESeq{}) = True+isESeq _              = False+ -----------------------------------------------------------------  cmd1 :: Cmd@@ -67,17 +79,40 @@                   (Var "x")              ) -result2 :: Expr-result2 = ESeq (Seq (Assign "m" (Lit 7))-                    (Assign "n" (Add (Lit 1) (Lit 2)))-               )-               (Add (Lit 7)-                    (Var "x")-               )+result2a :: Expr+result2a = ESeq (Seq (Assign "m" (Lit 7))+                     (Assign "n" (Add (Lit 1) (Lit 2)))+                )+                (Add (Lit 7)+                     (Var "x")+                ) -test2 :: Bool-test2 = applyE (extractR (anytdR inlineGR)) expr2 == Right result2+test2a :: Bool+test2a = applyE (extractR (anytdR inlineGR)) expr2 == Right result2a +----------------------------------------------------------------++assignMpath :: LocalPath Int+assignMpath = mempty @@ 0 @@ 0++assignNpath :: LocalPath Int+assignNpath = mempty @@ 0 @@ 1++test2b :: Bool+test2b = applyE (extractT $ pathsToT $ arr isAssign) expr2 == Right [assignMpath,assignNpath]++test2c :: Bool+test2c = applyE (extractT $ onePathToT $ arr isAssign) expr2 == Right assignMpath++test2d :: Bool+test2d = applyE (extractT $ oneNonEmptyPathToT $ arr isAssign) expr2 == Right assignMpath++test2e :: Bool+test2e = applyE (extractT $ onePathToT $ arr isESeq) expr2 == Right mempty++test2f :: Bool+test2f = applyE (extractT $ oneNonEmptyPathToT $ arr isESeq) expr2 == Left "No matching nodes found."+ -----------------------------------------------------------------  expr3 :: Expr@@ -144,7 +179,7 @@  checkTests :: Bool checkTests = and [ test1a, test1b, test1c-                 , test2+                 , test2a, test2b, test2c, test2d, test2e, test2f                  , test3a, test3b, test3c                  , test4a, test4b, test4c                  ]

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE InstanceSigs, LambdaCase, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}  module Expr.Kure where @@ -30,44 +30,44 @@  --------------------------------------------------------------------------- -instance Walker Context Generic where--- allR :: MonadCatch m => Rewrite Context m Generic -> Rewrite Context m Generic+instance (ExtendPath c Int, AddDef c) => Walker c Generic where+   allR :: MonadCatch m => Rewrite c m Generic -> Rewrite c m Generic    allR r = prefixFailMsg "allR failed: " $-            rewrite $ \ c g -> case g of+            rewrite $ \ c -> \case               GExpr e  -> inject <$> apply allRexpr c e               GCmd cm  -> inject <$> apply allRcmd c cm      where-       allRexpr = readerT $ \ expr -> case expr of+       allRexpr = readerT $ \case                     Add _ _  -> addAllR (extractR r) (extractR r)                     ESeq _ _ -> eseqAllR (extractR r) (extractR r)                     _        -> idR -       allRcmd  = readerT $ \ cmd -> case cmd of+       allRcmd  = readerT $ \case                     Seq _ _    -> seqAllR (extractR r) (extractR r)                     Assign _ _ -> assignR (extractR r)  --------------------------------------------------------------------------- -seqT :: Monad m => Translate Context m Cmd a1 -> Translate Context m Cmd a2 -> (a1 -> a2 -> b) -> Translate Context m Cmd b-seqT t1 t2 f = translate $ \ c cm -> case cm of-                                       Seq cm1 cm2 -> f <$> apply t1 (c @@ 0) cm1 <*> apply t2 (updateContextCmd cm1 c @@ 1) cm2-                                       _           -> fail "not a Seq"+seqT :: (ExtendPath c Int, AddDef c, Monad m) => Translate c m Cmd a1 -> Translate c m Cmd a2 -> (a1 -> a2 -> b) -> Translate c m Cmd b+seqT t1 t2 f = translate $ \ c -> \case+                                     Seq cm1 cm2 -> f <$> apply t1 (c @@ 0) cm1 <*> apply t2 (updateContextCmd cm1 c @@ 1) cm2+                                     _           -> fail "not a Seq" -seqAllR :: Monad m => Rewrite Context m Cmd -> Rewrite Context m Cmd -> Rewrite Context m Cmd+seqAllR :: (ExtendPath c Int, AddDef c, Monad m) => Rewrite c m Cmd -> Rewrite c m Cmd -> Rewrite c m Cmd seqAllR r1 r2 = seqT r1 r2 Seq -seqAnyR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Cmd -> Rewrite Context m Cmd+seqAnyR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Cmd -> Rewrite c m Cmd seqAnyR r1 r2 = unwrapAnyR $ seqAllR (wrapAnyR r1) (wrapAnyR r2) -seqOneR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Cmd -> Rewrite Context m Cmd+seqOneR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Cmd -> Rewrite c m Cmd seqOneR r1 r2 = unwrapOneR $ seqAllR (wrapOneR r1) (wrapOneR r2)  ---------------------------------------------------------------------------  assignT :: (ExtendPath c Int, Monad m) => Translate c m Expr a -> (Name -> a -> b) -> Translate c m Cmd b-assignT t f = translate $ \ c cm -> case cm of-                                      Assign n e -> f n <$> apply t (c @@ 0) e-                                      _          -> fail "not an Assign"+assignT t f = translate $ \ c -> \case+                                    Assign n e -> f n <$> apply t (c @@ 0) e+                                    _          -> fail "not an Assign"  assignR :: (ExtendPath c Int, Monad m) => Rewrite c m Expr -> Rewrite c m Cmd assignR r = assignT r Assign@@ -75,23 +75,23 @@ ---------------------------------------------------------------------------  varT :: Monad m => (Name -> b) -> Translate c m Expr b-varT f = contextfreeT $ \ e -> case e of-                                 Var v -> return (f v)-                                 _     -> fail "not a Var"+varT f = contextfreeT $ \case+                           Var v -> return (f v)+                           _     -> fail "not a Var"  ---------------------------------------------------------------------------  litT :: Monad m => (Int -> b) -> Translate c m Expr b-litT f = contextfreeT $ \ e -> case e of-                                 Lit v -> return (f v)-                                 _     -> fail "not a Lit"+litT f = contextfreeT $ \case+                           Lit v -> return (f v)+                           _     -> fail "not a Lit"  ---------------------------------------------------------------------------  addT :: (ExtendPath c Int, Monad m) => Translate c m Expr a1 -> Translate c m Expr a2 -> (a1 -> a2 -> b) -> Translate c m Expr b-addT t1 t2 f = translate $ \ c e -> case e of-                                      Add e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2-                                      _         -> fail "not an Add"+addT t1 t2 f = translate $ \ c -> \case+                                     Add e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2+                                     _         -> fail "not an Add"  addAllR :: (ExtendPath c Int, Monad m) => Rewrite c m Expr -> Rewrite c m Expr -> Rewrite c m Expr addAllR r1 r2 = addT r1 r2 Add@@ -104,18 +104,18 @@  --------------------------------------------------------------------------- -eseqT :: Monad m => Translate Context m Cmd a1 -> Translate Context m Expr a2 -> (a1 -> a2 -> b) -> Translate Context m Expr b-eseqT t1 t2 f = translate $ \ c e -> case e of-                                       ESeq cm e1 -> f <$> apply t1 (c @@ 0) cm <*> apply t2 (updateContextCmd cm c @@ 1) e1-                                       _          -> fail "not an ESeq"+eseqT :: (ExtendPath c Int, AddDef c, Monad m) => Translate c m Cmd a1 -> Translate c m Expr a2 -> (a1 -> a2 -> b) -> Translate c m Expr b+eseqT t1 t2 f = translate $ \ c -> \case+                                      ESeq cm e1 -> f <$> apply t1 (c @@ 0) cm <*> apply t2 (updateContextCmd cm c @@ 1) e1+                                      _          -> fail "not an ESeq" -eseqAllR :: Monad m => Rewrite Context m Cmd -> Rewrite Context m Expr -> Rewrite Context m Expr+eseqAllR :: (ExtendPath c Int, AddDef c, Monad m) => Rewrite c m Cmd -> Rewrite c m Expr -> Rewrite c m Expr eseqAllR r1 r2 = eseqT r1 r2 ESeq -eseqAnyR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Expr -> Rewrite Context m Expr+eseqAnyR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Expr -> Rewrite c m Expr eseqAnyR r1 r2 = unwrapAnyR $ eseqAllR (wrapAnyR r1) (wrapAnyR r2) -eseqOneR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Expr -> Rewrite Context m Expr+eseqOneR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Expr -> Rewrite c m Expr eseqOneR r1 r2 = unwrapOneR $ eseqAllR (wrapOneR r1) (wrapOneR r2)  ---------------------------------------------------------------------------

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE InstanceSigs, LambdaCase, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}  module Fib.Kure (Crumb(..)) where @@ -15,14 +15,13 @@ data Crumb = LeftChild | RightChild | OnlyChild deriving (Eq,Show)  instance ExtendPath c Crumb => Walker c Arith where--- allR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Arith -> Rewrite c m Arith+   allR :: MonadCatch m => Rewrite c m Arith -> Rewrite c m Arith    allR r = prefixFailMsg "allR failed: " $-     rewrite $ \ c e ->-         case e of-           Lit n      ->  Lit <$> return n-           Add e0 e1  ->  Add <$> apply r (c @@ LeftChild) e0 <*> apply r (c @@ RightChild) e1-           Sub e0 e1  ->  Sub <$> apply r (c @@ LeftChild) e0 <*> apply r (c @@ RightChild) e1-           Fib e0     ->  Fib <$> apply r (c @@ OnlyChild) e0+     rewrite $ \ c -> \case+                         Lit n      ->  Lit <$> return n+                         Add e0 e1  ->  Add <$> apply r (c @@ LeftChild) e0 <*> apply r (c @@ RightChild) e1+                         Sub e0 e1  ->  Sub <$> apply r (c @@ LeftChild) e0 <*> apply r (c @@ RightChild) e1+                         Fib e0     ->  Fib <$> apply r (c @@ OnlyChild) e0  -------------------------------------------------------------------------------------- 

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses #-} module Lam.Context where  import Data.Monoid (mempty)@@ -22,15 +22,15 @@   addBoundVar :: Name -> c -> c  instance AddBoundVar LamC where--- addBoundVar :: Name -> LamC -> LamC+   addBoundVar :: Name -> LamC -> LamC    addBoundVar v (LamC p vs) = LamC p (v:vs)  instance ExtendPath LamC Crumb where--- (@@) :: LamC -> Crumb -> LamC+   (@@) :: LamC -> Crumb -> LamC    (LamC p vs) @@ cr = LamC (p @@ cr) vs  instance ReadPath LamC Crumb where--- absPath :: LamC -> AbsolutePath Crumb+   absPath :: LamC -> AbsolutePath Crumb    absPath (LamC p _) = p  initialLamC :: LamC

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}+{-# LANGUAGE InstanceSigs, LambdaCase, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}  module Lam.Kure where @@ -12,12 +12,12 @@ -------------------------------------------------------------------------------  instance (ExtendPath c Crumb, AddBoundVar c) => Walker c Exp where--- allR :: MonadCatch m => Rewrite LamC m Exp -> Rewrite LamC m Exp+   allR :: MonadCatch m => Rewrite c m Exp -> Rewrite c m Exp    allR r = prefixFailMsg "allR failed: " $-            readerT $ \ e -> case e of-              App _ _ -> appAllR r r-              Lam _ _ -> lamR r-              _       -> idR+            readerT $ \case+                         App _ _ -> appAllR r r+                         Lam _ _ -> lamR r+                         _       -> idR  ------------------------------------------------------------------------------- @@ -25,16 +25,16 @@ --   Using these ensures that the context is updated consistantly.  varT :: Monad m => (Name -> b) -> Translate c m Exp b-varT f = contextfreeT $ \ e -> case e of-                                 Var n -> return (f n)-                                 _     -> fail "no match for Var"+varT f = contextfreeT $ \case+                           Var n -> return (f n)+                           _     -> fail "no match for Var"  -------------------------------------------------------------------------------  lamT :: (ExtendPath c Crumb, AddBoundVar c, Monad m) => Translate c m Exp a -> (Name -> a -> b) -> Translate c m Exp b-lamT t f = translate $ \ c e -> case e of-                                  Lam v e1 -> f v <$> apply t (addBoundVar v c @@ Lam_Body) e1-                                  _        -> fail "no match for Lam"+lamT t f = translate $ \ c -> \case+                                 Lam v e -> f v <$> apply t (addBoundVar v c @@ Lam_Body) e+                                 _       -> fail "no match for Lam"  lamR :: (ExtendPath c Crumb, AddBoundVar c, Monad m) => Rewrite c m Exp -> Rewrite c m Exp lamR r = lamT r Lam@@ -42,9 +42,9 @@ -------------------------------------------------------------------------------  appT :: (ExtendPath c Crumb, Monad m) => Translate c m Exp a1 -> Translate c m Exp a2 -> (a1 -> a2 -> b) -> Translate c m Exp b-appT t1 t2 f = translate $ \ c e -> case e of-                                      App e1 e2 -> f <$> apply t1 (c @@ App_Fun) e1 <*> apply t2 (c @@ App_Arg) e2-                                      _         -> fail "no match for App"+appT t1 t2 f = translate $ \ c -> \case+                                     App e1 e2 -> f <$> apply t1 (c @@ App_Fun) e1 <*> apply t2 (c @@ App_Arg) e2+                                     _         -> fail "no match for App"  appAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Exp -> Rewrite c m Exp -> Rewrite c m Exp appAllR r1 r2 = appT r1 r2 App

@@ -1,3 +1,5 @@+{-# Language InstanceSigs #-}+ module Lam.Monad where  import Language.KURE@@ -13,23 +15,33 @@ runLamM m = snd (lamM m 0)  instance Monad LamM where+  return :: a -> LamM a   return a = LamM (\n -> (n,Right a))++  fail :: String -> LamM a+  fail msg = LamM (\ n -> (n, Left msg))++  (>>=) :: LamM a -> (a -> LamM b) -> LamM b   (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 +  catchM :: LamM a -> (String -> LamM a) -> LamM a   (LamM st) `catchM` f = LamM $ \ n -> case st n of                                         (n', Left msg) -> lamM (f msg) n'                                         (n', Right a)  -> (n', Right a)  instance Functor LamM where+  fmap :: (a -> b) -> LamM a -> LamM b   fmap = liftM  instance Applicative LamM where+  pure :: a -> LamM a   pure  = return++  (<*>) :: LamM (a -> b) -> LamM a -> LamM b   (<*>) = ap  -------------------------------------------------------------------------------

@@ -1,5 +1,5 @@ Name:                kure-Version:             2.8.0+Version:             2.12.0 Synopsis:            Combinators for Strategic Programming Description:	     The Kansas University Rewrite Engine (KURE) is a domain-specific language for strategic rewriting. 	 	     KURE was inspired by Stratego and StrategyLib, and has similarities with Scrap Your Boilerplate and Uniplate.@@ -41,7 +41,8 @@  Library   Build-Depends: base >= 4.5 && < 5,-                 dlist >= 0.2 && < 1+                 dlist >= 0.2 && < 1,+                 ghc >= 7.6   Ghc-Options: -Wall   Exposed-modules:        Language.KURE@@ -51,10 +52,12 @@        Language.KURE.Combinators.Monad        Language.KURE.Combinators.Translate        Language.KURE.Debug+       Language.KURE.ExtendableContext        Language.KURE.Injection        Language.KURE.Lens        Language.KURE.MonadCatch        Language.KURE.Path+       Language.KURE.Pathfinder        Language.KURE.Translate        Language.KURE.Walker