kure 2.14.6 → 2.16.0
raw patch · 26 files changed
+824/−802 lines, 26 files
Files
- LICENSE +1/−1
- Language/KURE.hs +4/−4
- Language/KURE/BiTransform.hs +76/−0
- Language/KURE/BiTranslate.hs +0/−73
- Language/KURE/Combinators.hs +4/−4
- Language/KURE/Combinators/Arrow.hs +1/−1
- Language/KURE/Combinators/Monad.hs +1/−1
- Language/KURE/Combinators/Transform.hs +315/−0
- Language/KURE/Combinators/Translate.hs +0/−315
- Language/KURE/Debug.hs +5/−5
- Language/KURE/ExtendableContext.hs +1/−1
- Language/KURE/Injection.hs +15/−15
- Language/KURE/Lens.hs +21/−21
- Language/KURE/MonadCatch.hs +1/−1
- Language/KURE/Path.hs +5/−5
- Language/KURE/Pathfinder.hs +16/−16
- Language/KURE/Transform.hs +243/−0
- Language/KURE/Translate.hs +0/−224
- Language/KURE/Walker.hs +71/−71
- examples/Expr/Examples.hs +4/−4
- examples/Expr/Kure.hs +16/−16
- examples/Fib/Examples.hs +5/−5
- examples/Fib/Kure.hs +3/−3
- examples/Lam/Examples.hs +5/−5
- examples/Lam/Kure.hs +7/−7
- kure.cabal +4/−4
LICENSE view
@@ -1,4 +1,4 @@-(c) 2006-2013 The University of Kansas+(c) 2006-2014 The University of Kansas All rights reserved. Redistribution and use in source and binary forms, with or without
Language/KURE.hs view
@@ -1,6 +1,6 @@ -- | -- Module: Language.KURE--- Copyright: (c) 2012 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -8,11 +8,11 @@ -- Portability: ghc -- -- This is the main import module for KURE, which exports all the major components.--- The basic transformation functionality can be found in "Language.KURE.Translate",+-- The basic transformation functionality can be found in "Language.KURE.Transform", -- and the traversal functionality can be found in "Language.KURE.Walker". -- module Language.KURE- ( module Language.KURE.Translate+ ( module Language.KURE.Transform , module Language.KURE.Walker , module Language.KURE.Combinators , module Language.KURE.MonadCatch@@ -22,7 +22,7 @@ import Language.KURE.Combinators import Language.KURE.MonadCatch-import Language.KURE.Translate+import Language.KURE.Transform import Language.KURE.Injection import Language.KURE.Path import Language.KURE.Walker
+ Language/KURE/BiTransform.hs view
@@ -0,0 +1,76 @@+{-# Language InstanceSigs #-}+-- |+-- Module: Language.KURE.BiTransform+-- Copyright: (c) 2012--2014 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- A bi-directional transformation is a transformation that can be applied in either direction.++module Language.KURE.BiTransform+ ( -- * Bi-directional Transformations+ BiTransform, BiTranslate+ , BiRewrite+ , bidirectional+ , forwardT+ , backwardT+ , whicheverR+ , invertBiT+ , beforeBiR+) where++import Prelude hiding (id, (.))++import Control.Category++import Language.KURE.MonadCatch+import Language.KURE.Transform++------------------------------------------------------------------------------------------++-- | An undirected 'Transform'.+data BiTransform c m a b = BiTransform {forwardT :: Transform c m a b, -- ^ Extract the forward 'Transform' from a 'BiTransform'.+ backwardT :: Transform c m b a -- ^ Extract the backward 'Transform' from a 'BiTransform'.+ }++-- | A deprecated synonym for 'BiTranslate'.+type BiTranslate c m a b = BiTransform c m a b++-- | A 'BiTransform' that shares the same source and target type.+type BiRewrite c m a = BiTransform c m a a++-- | Construct a 'BiTransform' from two opposite 'Transform's.+bidirectional :: Transform c m a b -> Transform c m b a -> BiTransform c m a b+bidirectional = BiTransform+{-# INLINE bidirectional #-}++-- | Try the 'BiRewrite' forwards, 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 = forwardT r <+ backwardT r+{-# INLINE whicheverR #-}++-- | Invert the forwards and backwards directions of a 'BiTransform'.+invertBiT :: BiTransform c m a b -> BiTransform c m b a+invertBiT (BiTransform t1 t2) = BiTransform t2 t1+{-# INLINE invertBiT #-}++instance Monad m => Category (BiTransform c m) where+ id :: BiTransform c m a a+ id = bidirectional id id+ {-# INLINE id #-}++ (.) :: BiTransform c m b d -> BiTransform c m a b -> BiTransform c m a d+ (BiTransform f1 b1) . (BiTransform f2 b2) = BiTransform (f1 . f2) (b2 . b1)+ {-# INLINE (.) #-}+++-- | Perform the argument transformation before /either/ direction of the bidirectional rewrite.+beforeBiR :: Monad m => Transform c m a b -> (b -> BiRewrite c m a) -> BiRewrite c m a+beforeBiR t f = bidirectional (t >>= (forwardT . f)) (t >>= (backwardT . f))+{-# INLINE beforeBiR #-}++------------------------------------------------------------------------------------------
− Language/KURE/BiTranslate.hs
@@ -1,73 +0,0 @@-{-# Language InstanceSigs #-}--- |--- Module: Language.KURE.BiTranslate--- Copyright: (c) 2012--2013 The University of Kansas--- License: BSD3------ Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>--- Stability: beta--- Portability: ghc------ A bi-directional translation is a translation that can be applied in either direction.--module Language.KURE.BiTranslate- ( -- * Bi-directional Translations- BiTranslate- , BiRewrite- , bidirectional- , forwardT- , backwardT- , whicheverR- , invertBiT- , beforeBiR-) where--import Prelude hiding (id, (.))--import Control.Category--import Language.KURE.MonadCatch-import Language.KURE.Translate------------------------------------------------------------------------------------------------ | An undirected 'Translate'.-data BiTranslate c m a b = BiTranslate {forwardT :: Translate c m a b, -- ^ Extract the forward 'Translate' from a 'BiTranslate'.- backwardT :: Translate c m b a -- ^ Extract the backward 'Translate' from a 'BiTranslate'.- }---- | A 'BiTranslate' that shares the same source and target type.-type BiRewrite c m a = BiTranslate c m a a---- | 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-{-# INLINE bidirectional #-}---- | Try the 'BiRewrite' forwards, 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 = forwardT r <+ backwardT r-{-# INLINE whicheverR #-}---- | Invert the forwards and backwards directions of a 'BiTranslate'.-invertBiT :: BiTranslate c m a b -> BiTranslate c m b a-invertBiT (BiTranslate t1 t2) = BiTranslate t2 t1-{-# INLINE invertBiT #-}--instance Monad m => Category (BiTranslate c m) where- 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 f1 b1) . (BiTranslate f2 b2) = BiTranslate (f1 . f2) (b2 . b1)- {-# INLINE (.) #-}----- | Perform the argument translation before /either/ direction of the bidirectional rewrite.-beforeBiR :: Monad m => Translate c m a b -> (b -> BiRewrite c m a) -> BiRewrite c m a-beforeBiR t f = bidirectional (t >>= (forwardT . f)) (t >>= (backwardT . f))-{-# INLINE beforeBiR #-}--------------------------------------------------------------------------------------------
Language/KURE/Combinators.hs view
@@ -1,6 +1,6 @@ -- | -- Module: Language.KURE.Combinators--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -8,17 +8,17 @@ -- Portability: ghc -- -- This module provides various monadic and arrow combinators that are useful when--- working with 'Language.KURE.Translate.Translate's and 'Language.KURE.Translate.Rewrite's.+-- working with 'Language.KURE.Transform.Transform's and 'Language.KURE.Transform.Rewrite's. module Language.KURE.Combinators (- module Language.KURE.Combinators.Translate+ module Language.KURE.Combinators.Transform , module Language.KURE.Combinators.Monad , module Language.KURE.Combinators.Arrow ) where import Language.KURE.Combinators.Monad import Language.KURE.Combinators.Arrow-import Language.KURE.Combinators.Translate+import Language.KURE.Combinators.Transform ------------------------------------------------------------------------------------------
Language/KURE/Combinators/Arrow.hs view
@@ -1,6 +1,6 @@ -- | -- Module: Language.KURE.Combinators.Arrow--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>
Language/KURE/Combinators/Monad.hs view
@@ -1,6 +1,6 @@ -- | -- Module: Language.KURE.Combinators.Monad--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>
+ Language/KURE/Combinators/Transform.hs view
@@ -0,0 +1,315 @@+{-# Language InstanceSigs #-}+-- |+-- Module: Language.KURE.Combinators.Transform+-- Copyright: (c) 2012--2014 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides a variety of combinators over 'Transform' and 'Rewrite'.++module Language.KURE.Combinators.Transform+ ( -- * Transformation Combinators+ idR+ , successT+ , contextT+ , exposeT+ , liftContext+ , readerT+ , resultT+ , catchesT+ , mapT+ , joinT+ , guardT+ -- * Rewrite Combinators+ , tryR+ , andR+ , orR+ , (>+>)+ , repeatR+ , acceptR+ , acceptWithFailMsgR+ , accepterR+ , changedR+ , changedByR+ , sideEffectR+ -- * Monad Transformers+ -- ** anyR Support+ -- $AnyR_doc+ , AnyR+ , wrapAnyR+ , unwrapAnyR+ -- ** oneR Support+ -- $OneR_doc+ , OneR+ , wrapOneR+ , unwrapOneR+) where++import Prelude hiding (id, map, foldr, mapM)++import Control.Category ((>>>),id)+import Control.Applicative+import Control.Monad (liftM,ap)++import Data.Foldable+import Data.Traversable++import Language.KURE.Combinators.Arrow+import Language.KURE.Combinators.Monad+import Language.KURE.MonadCatch+import Language.KURE.Transform++------------------------------------------------------------------------------------------++-- | The identity rewrite.+idR :: Monad m => Rewrite c m a+idR = id+{-# INLINE idR #-}++-- | An always successful transformation.+successT :: Monad m => Transform c m a ()+successT = return ()+{-# INLINE successT #-}++-- | Extract the current context.+contextT :: Monad m => Transform c m a c+contextT = transform (\ c _ -> return c)+{-# INLINE contextT #-}++-- | Expose the current context and value.+exposeT :: Monad m => Transform c m a (c,a)+exposeT = transform (curry return)+{-# INLINE exposeT #-}++-- | Lift a transformation to operate on a derived context.+liftContext :: (c -> c') -> Transform c' m a b -> Transform c m a b+liftContext f t = transform (applyT t . f)+{-# INLINE liftContext #-}++-- | Map a transformation over a list.+mapT :: (Traversable t, Monad m) => Transform c m a b -> Transform c m (t a) (t b)+mapT t = transform (mapM . applyT t)+{-# INLINE mapT #-}++-- | An identity rewrite with side-effects.+sideEffectR :: Monad m => (c -> a -> m ()) -> Rewrite c m a+sideEffectR f = transform f >> id+{-# INLINE sideEffectR #-}++-- | Look at the argument to the transformation before choosing which 'Transform' to use.+readerT :: (a -> Transform c m a b) -> Transform c m a b+readerT f = transform (\ c a -> applyT (f a) c a)+{-# INLINE readerT #-}++-- | Convert the monadic result of a transformation into a result in another monad.+resultT :: (m b -> n d) -> Transform c m a b -> Transform c n a d+resultT f t = transform (\ c -> f . applyT t c)+{-# INLINE resultT #-}++-- | Perform a collection of rewrites in sequence, requiring all to succeed.+andR :: (Foldable f, Monad m) => f (Rewrite c m a) -> Rewrite c m a+andR = serialise+{-# INLINE andR #-}++-- | Perform two rewrites in sequence, succeeding if one or both succeed.+(>+>) :: MonadCatch m => Rewrite c m a -> Rewrite c m a -> Rewrite c m a+r1 >+> r2 = unwrapAnyR (wrapAnyR r1 >>> wrapAnyR r2)+{-# INLINE (>+>) #-}++-- | Perform a collection of rewrites in sequence, succeeding if any succeed.+orR :: (Functor f, Foldable f, MonadCatch m) => f (Rewrite c m a) -> Rewrite c m a+orR = unwrapAnyR . andR . fmap wrapAnyR+{-# INLINE orR #-}++-- | As 'acceptR', but takes a custom failure message.+acceptWithFailMsgR :: Monad m => (a -> Bool) -> String -> Rewrite c m a+acceptWithFailMsgR p msg = readerT $ \ a -> if p a then id else fail msg+{-# INLINE acceptWithFailMsgR #-}++-- | 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 #-}++-- | A generalisation of 'acceptR' where the predicate is a 'Transform'.+accepterR :: Monad m => Transform c m a Bool -> Rewrite c m a+accepterR t = ifM t idR (fail "accepterR: predicate failed")+{-# INLINE accepterR #-}++-- | 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 = changedByR (==)+{-# INLINE changedR #-}++-- | Repeat a rewrite until it fails, then return the result before the failure.+-- Requires at least the first attempt to succeed.+repeatR :: MonadCatch m => Rewrite c m a -> Rewrite c m a+repeatR r = let go = r >>> tryR go+ in go+{-# INLINE repeatR #-}++-- | Attempt each trransformation until one succeeds, then return that result and discard the rest of the transformations.+catchesT :: MonadCatch m => [Transform c m a b] -> Transform c m a b+catchesT = foldr (<+) (fail "catchesT failed")+{-# INLINE catchesT #-}++-- | An identity transformation that resembles a monadic 'Control.Monad.join'.+joinT :: Transform c m (m a) a+joinT = contextfreeT id+{-# INLINE joinT #-}++-- | Fail if the Boolean is False, succeed if the Boolean is True.+guardT :: Monad m => Transform c m Bool ()+guardT = contextfreeT guardM+{-# INLINE guardT #-}++-------------------------------------------------------------------------------++data PBool a = PBool !Bool a++instance Functor PBool where+ fmap :: (a -> b) -> PBool a -> PBool b+ fmap f (PBool b a) = PBool b (f a)++checkSuccessPBool :: Monad m => String -> m (PBool a) -> m a+checkSuccessPBool msg m = do PBool b a <- m+ if b+ then return a+ else fail msg+{-# INLINE checkSuccessPBool #-}++-------------------------------------------------------------------------------++-- $AnyR_doc+-- These are useful when defining congruence combinators that succeed if /any/ child rewrite succeeds.+-- See the \"Expr\" example, or the HERMIT package.++-- | The 'AnyR' transformer, in combination with 'wrapAnyR' and 'unwrapAnyR',+-- causes a sequence of rewrites to succeed if at least one succeeds, converting failures to+-- identity rewrites.+newtype AnyR m a = AnyR (m (PBool a))++unAnyR :: AnyR m a -> m (PBool a)+unAnyR (AnyR mba) = mba+{-# INLINE unAnyR #-}++instance Monad m => Functor (AnyR m) where+ fmap :: (a -> b) -> AnyR m a -> AnyR m b+ fmap = liftM+ {-# INLINE fmap #-}++instance Monad m => Applicative (AnyR m) where+ pure :: a -> AnyR m a+ pure = return+ {-# INLINE pure #-}++ (<*>) :: AnyR m (a -> b) -> AnyR m a -> AnyR m b+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad m => Monad (AnyR m) where+ return :: a -> AnyR m a+ return = AnyR . return . PBool False+ {-# INLINE return #-}++ fail :: String -> AnyR m a+ fail = AnyR . fail+ {-# INLINE fail #-}++ (>>=) :: 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 ma f = AnyR (unAnyR ma `catchM` (unAnyR . f))+ {-# INLINE catchM #-}++-- | Wrap a 'Rewrite' using the 'AnyR' monad transformer.+wrapAnyR :: MonadCatch m => Rewrite c m a -> Rewrite c (AnyR m) a+wrapAnyR r = rewrite $ \ c a -> AnyR $ (PBool True `liftM` applyR r c a) <+ return (PBool False a)+{-# INLINE wrapAnyR #-}++-- | Unwrap a 'Rewrite' from the 'AnyR' monad transformer.+unwrapAnyR :: Monad m => Rewrite c (AnyR m) a -> Rewrite c m a+unwrapAnyR = resultT (checkSuccessPBool "anyR failed" . unAnyR)+{-# INLINE unwrapAnyR #-}++-------------------------------------------------------------------------------++-- $OneR_doc+-- These are useful when defining congruence combinators that succeed if one child rewrite succeeds+-- (and the remainder are then discarded).+-- See the \"Expr\" example, or the HERMIT package.++-- | The 'OneR' transformer, in combination with 'wrapOneR' and 'unwrapOneR',+-- causes a sequence of rewrites to only apply the first success, converting the remainder (and failures) to identity rewrites.+newtype OneR m a = OneR (Bool -> m (PBool a))++unOneR :: OneR m a -> Bool -> m (PBool a)+unOneR (OneR mba) = mba+{-# INLINE unOneR #-}++instance Monad m => Functor (OneR m) where+ fmap :: (a -> b) -> OneR m a -> OneR m b+ fmap = liftM+ {-# INLINE fmap #-}++instance Monad m => Applicative (OneR m) where+ pure :: a -> OneR m a+ pure = return+ {-# INLINE pure #-}++ (<*>) :: OneR m (a -> b) -> OneR m a -> OneR m b+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad m => Monad (OneR m) where+ return :: a -> OneR m a+ return a = OneR (\ b -> return (PBool b a))+ {-# INLINE return #-}++ fail :: String -> OneR m a+ fail msg = OneR (\ _ -> fail msg)+ {-# INLINE fail #-}++ (>>=) :: 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 g) f = OneR (\ b -> g b `catchM` (($ b) . unOneR . f))+ {-# INLINE catchM #-}++-- | Wrap a 'Rewrite' using the 'OneR' monad transformer.+wrapOneR :: MonadCatch m => Rewrite c m g -> Rewrite c (OneR m) g+wrapOneR r = rewrite $ \ c a -> OneR $ \ b -> if b+ then return (PBool True a)+ else (PBool True `liftM` applyR r c a) <+ return (PBool False a)+{-# INLINE wrapOneR #-}++-- | Unwrap a 'Rewrite' from the 'OneR' monad transformer.+unwrapOneR :: Monad m => Rewrite c (OneR m) a -> Rewrite c m a+unwrapOneR = resultT (checkSuccessPBool "oneR failed" . ($ False) . unOneR)+{-# INLINE unwrapOneR #-}++-------------------------------------------------------------------------------
− Language/KURE/Combinators/Translate.hs
@@ -1,315 +0,0 @@-{-# Language InstanceSigs #-}--- |--- Module: Language.KURE.Combinators.Translate--- 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 variety of combinators over 'Translate' and 'Rewrite'.--module Language.KURE.Combinators.Translate- ( -- * Translate Combinators- idR- , successT- , contextT- , exposeT- , liftContext- , readerT- , resultT- , catchesT- , mapT- , joinT- , guardT- -- * Rewrite Combinators- , tryR- , andR- , orR- , (>+>)- , repeatR- , acceptR- , acceptWithFailMsgR- , accepterR- , changedR- , changedByR- , sideEffectR- -- * Monad Transformers- -- ** anyR Support- -- $AnyR_doc- , AnyR- , wrapAnyR- , unwrapAnyR- -- ** oneR Support- -- $OneR_doc- , OneR- , wrapOneR- , unwrapOneR-) where--import Prelude hiding (id, map, foldr, mapM)--import Control.Category ((>>>),id)-import Control.Applicative-import Control.Monad (liftM,ap)--import Data.Foldable-import Data.Traversable--import Language.KURE.Combinators.Arrow-import Language.KURE.Combinators.Monad-import Language.KURE.MonadCatch-import Language.KURE.Translate------------------------------------------------------------------------------------------------ | The identity 'Rewrite'.-idR :: Monad m => Rewrite c m a-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)-{-# INLINE contextT #-}---- | Expose the current context and value.-exposeT :: Monad m => Translate c m a (c,a)-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)-{-# INLINE mapT #-}---- | An identity 'Rewrite' with side-effects.-sideEffectR :: Monad m => (c -> a -> m ()) -> Rewrite c m a-sideEffectR f = translate f >> id-{-# INLINE sideEffectR #-}---- | Look at the argument to the 'Translate' before choosing which 'Translate' to use.-readerT :: (a -> Translate c m a b) -> Translate c m a b-readerT f = translate (\ c a -> apply (f a) c a)-{-# INLINE readerT #-}---- | Convert the monadic result of a 'Translate' into a result in another monad.-resultT :: (m b -> n d) -> Translate c m a b -> Translate c n a d-resultT f t = translate (\ c -> f . apply t c)-{-# INLINE resultT #-}---- | Perform a collection of rewrites in sequence, requiring all to succeed.-andR :: (Foldable f, Monad m) => f (Rewrite c m a) -> Rewrite c m a-andR = serialise-{-# INLINE andR #-}---- | Perform two rewrites in sequence, succeeding if one or both succeed.-(>+>) :: MonadCatch m => Rewrite c m a -> Rewrite c m a -> Rewrite c m a-r1 >+> r2 = unwrapAnyR (wrapAnyR r1 >>> wrapAnyR r2)-{-# INLINE (>+>) #-}---- | Perform a collection of rewrites in sequence, succeeding if any succeed.-orR :: (Functor f, Foldable f, MonadCatch m) => f (Rewrite c m a) -> Rewrite c m a-orR = unwrapAnyR . andR . fmap wrapAnyR-{-# INLINE orR #-}---- | As 'acceptR', but takes a custom failure message.-acceptWithFailMsgR :: Monad m => (a -> Bool) -> String -> Rewrite c m a-acceptWithFailMsgR p msg = readerT $ \ a -> if p a then id else fail msg-{-# INLINE acceptWithFailMsgR #-}---- | 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 #-}---- | A generalisation of 'acceptR' where the predicate is a 'Translate'.-accepterR :: Monad m => Translate c m a Bool -> Rewrite c m a-accepterR t = ifM t idR (fail "accepterR: predicate failed")-{-# INLINE accepterR #-}---- | 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 = changedByR (==)-{-# INLINE changedR #-}---- | Repeat a 'Rewrite' until it fails, then return the result before the failure.--- Requires at least the first attempt to succeed.-repeatR :: MonadCatch m => Rewrite c m a -> Rewrite c m a-repeatR r = let go = r >>> tryR go- in go-{-# INLINE repeatR #-}---- | Attempt each 'Translate' until one succeeds, then return that result and discard the rest of the 'Translate's.-catchesT :: MonadCatch m => [Translate c m a b] -> Translate c m a b-catchesT = foldr (<+) (fail "catchesT failed")-{-# INLINE catchesT #-}---- | An identity translation that resembles a monadic 'Control.Monad.join'.-joinT :: Translate c m (m a) a-joinT = contextfreeT id-{-# INLINE joinT #-}---- | Fail if the Boolean is False, succeed if the Boolean is True.-guardT :: Monad m => Translate c m Bool ()-guardT = contextfreeT guardM-{-# INLINE guardT #-}-----------------------------------------------------------------------------------data PBool a = PBool !Bool a--instance Functor PBool where- fmap :: (a -> b) -> PBool a -> PBool b- fmap f (PBool b a) = PBool b (f a)--checkSuccessPBool :: Monad m => String -> m (PBool a) -> m a-checkSuccessPBool msg m = do PBool b a <- m- if b- then return a- else fail msg-{-# INLINE checkSuccessPBool #-}------------------------------------------------------------------------------------- $AnyR_doc--- These are useful when defining congruence combinators that succeed if /any/ child rewrite succeeds.--- See the \"Expr\" example, or the HERMIT package.---- | The 'AnyR' transformer, in combination with 'wrapAnyR' and 'unwrapAnyR',--- causes a sequence of rewrites to succeed if at least one succeeds, converting failures to--- identity rewrites.-newtype AnyR m a = AnyR (m (PBool a))--unAnyR :: AnyR m a -> m (PBool a)-unAnyR (AnyR mba) = mba-{-# INLINE unAnyR #-}--instance Monad m => Functor (AnyR m) where- fmap :: (a -> b) -> AnyR m a -> AnyR m b- fmap = liftM- {-# INLINE fmap #-}--instance Monad m => Applicative (AnyR m) where- pure :: a -> AnyR m a- pure = return- {-# INLINE pure #-}-- (<*>) :: AnyR m (a -> b) -> AnyR m a -> AnyR m b- (<*>) = ap- {-# INLINE (<*>) #-}--instance Monad m => Monad (AnyR m) where- return :: a -> AnyR m a- return = AnyR . return . PBool False- {-# INLINE return #-}-- fail :: String -> AnyR m a- fail = AnyR . fail- {-# INLINE fail #-}-- (>>=) :: 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 ma f = AnyR (unAnyR ma `catchM` (unAnyR . f))- {-# INLINE catchM #-}---- | Wrap a 'Rewrite' using the 'AnyR' monad transformer.-wrapAnyR :: MonadCatch m => Rewrite c m a -> Rewrite c (AnyR m) a-wrapAnyR r = rewrite $ \ c a -> AnyR $ (PBool True `liftM` apply r c a) <+ return (PBool False a)-{-# INLINE wrapAnyR #-}---- | Unwrap a 'Rewrite' from the 'AnyR' monad transformer.-unwrapAnyR :: Monad m => Rewrite c (AnyR m) a -> Rewrite c m a-unwrapAnyR = resultT (checkSuccessPBool "anyR failed" . unAnyR)-{-# INLINE unwrapAnyR #-}------------------------------------------------------------------------------------- $OneR_doc--- These are useful when defining congruence combinators that succeed if one child rewrite succeeds--- (and the remainder are then discarded).--- See the \"Expr\" example, or the HERMIT package.---- | The 'OneR' transformer, in combination with 'wrapOneR' and 'unwrapOneR',--- causes a sequence of rewrites to only apply the first success, converting the remainder (and failures) to identity rewrites.-newtype OneR m a = OneR (Bool -> m (PBool a))--unOneR :: OneR m a -> Bool -> m (PBool a)-unOneR (OneR mba) = mba-{-# INLINE unOneR #-}--instance Monad m => Functor (OneR m) where- fmap :: (a -> b) -> OneR m a -> OneR m b- fmap = liftM- {-# INLINE fmap #-}--instance Monad m => Applicative (OneR m) where- pure :: a -> OneR m a- pure = return- {-# INLINE pure #-}-- (<*>) :: OneR m (a -> b) -> OneR m a -> OneR m b- (<*>) = ap- {-# INLINE (<*>) #-}--instance Monad m => Monad (OneR m) where- return :: a -> OneR m a- return a = OneR (\ b -> return (PBool b a))- {-# INLINE return #-}-- fail :: String -> OneR m a- fail msg = OneR (\ _ -> fail msg)- {-# INLINE fail #-}-- (>>=) :: 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 g) f = OneR (\ b -> g b `catchM` (($ b) . unOneR . f))- {-# INLINE catchM #-}---- | Wrap a 'Rewrite' using the 'OneR' monad transformer.-wrapOneR :: MonadCatch m => Rewrite c m g -> Rewrite c (OneR m) g-wrapOneR r = rewrite $ \ c a -> OneR $ \ b -> if b- then return (PBool True a)- else (PBool True `liftM` apply r c a) <+ return (PBool False a)-{-# INLINE wrapOneR #-}---- | Unwrap a 'Rewrite' from the 'OneR' monad transformer.-unwrapOneR :: Monad m => Rewrite c (OneR m) a -> Rewrite c m a-unwrapOneR = resultT (checkSuccessPBool "oneR failed" . ($ False) . unOneR)-{-# INLINE unwrapOneR #-}---------------------------------------------------------------------------------
Language/KURE/Debug.hs view
@@ -1,6 +1,6 @@ -- |--- Module: Language.KURE.Combinators.Translate--- Copyright: (c) 2012--2013 The University of Kansas+-- Module: Language.KURE.Debug+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -15,10 +15,10 @@ import Debug.Trace -import Language.KURE.Combinators.Translate-import Language.KURE.Translate+import Language.KURE.Combinators.Transform+import Language.KURE.Transform --- | trace output of the value being rewritten; use for debugging only.+-- | Trace output of the value being rewritten; use for debugging only. debugR :: (Monad m, Show a) => Int -> String -> Rewrite c m a debugR n msg = acceptR (\ a -> trace (msg ++ " : " ++ take n (show a)) True)
Language/KURE/ExtendableContext.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} -- | -- Module: Language.KURE.ExtendableContext--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>
Language/KURE/Injection.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module: Language.KURE.Injection--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -9,7 +9,7 @@ -- Portability: ghc -- -- This module provides a type class for injective functions (and their projections),--- and some useful interactions with 'Translate'.+-- and some useful interactions with 'Transform'. -- module Language.KURE.Injection ( -- * Injection Class@@ -18,7 +18,7 @@ , injectM , projectM , projectWithFailMsgM- -- * Translate Injections+ -- * Transformation Injections , injectT , projectT , extractT@@ -33,7 +33,7 @@ import Control.Arrow -import Language.KURE.Translate+import Language.KURE.Transform ------------------------------------------------------------------------------- @@ -85,32 +85,32 @@ ------------------------------------------------------------------------------- -- | Lifted 'inject'.-injectT :: (Monad m, Injection a g) => Translate c m a g+injectT :: (Monad m, Injection a g) => Transform c m a g injectT = arr inject {-# INLINE injectT #-} -projectWithFailMsgT :: (Monad m, Injection a g) => String -> Translate c m g a+projectWithFailMsgT :: (Monad m, Injection a g) => String -> Transform c m g a projectWithFailMsgT = contextfreeT . projectWithFailMsgM {-# INLINE projectWithFailMsgT #-} --- | Lifted 'project', the 'Translate' fails if the projection fails.-projectT :: (Monad m, Injection a g) => Translate c m g a+-- | Lifted 'project', the transformation fails if the projection fails.+projectT :: (Monad m, Injection a g) => Transform c m g a projectT = projectWithFailMsgT "projectT failed" {-# INLINE projectT #-} --- | Convert a 'Translate' over an injected value into a 'Translate' over a non-injected value.-extractT :: (Monad m, Injection a g) => Translate c m g b -> Translate c m a b+-- | Convert a transformation over an injected value into a transformation over a non-injected value.+extractT :: (Monad m, Injection a g) => Transform c m g b -> Transform c m a b extractT t = injectT >>> t {-# INLINE extractT #-} -- | As 'promoteT', but takes a custom error message to use if promotion fails.-promoteWithFailMsgT :: (Monad m, Injection a g) => String -> Translate c m a b -> Translate c m g b+promoteWithFailMsgT :: (Monad m, Injection a g) => String -> Transform c m a b -> Transform c m g b promoteWithFailMsgT msg t = projectWithFailMsgT msg >>> t {-# INLINE promoteWithFailMsgT #-} --- | Promote a 'Translate' over a value into a 'Translate' over an injection of that value,+-- | Promote a transformation over a value into a transformation over an injection of that value, -- (failing if that injected value cannot be projected).-promoteT :: (Monad m, Injection a g) => Translate c m a b -> Translate c m g b+promoteT :: (Monad m, Injection a g) => Transform c m a b -> Transform c m g b promoteT = promoteWithFailMsgT "promoteT failed" {-# INLINE promoteT #-} @@ -119,7 +119,7 @@ extractWithFailMsgR msg r = injectT >>> r >>> projectWithFailMsgT msg {-# INLINE extractWithFailMsgR #-} --- | Convert a 'Rewrite' over an injected value into a 'Rewrite' over a projection of that value,+-- | Convert a rewrite over an injected value into a rewrite over a projection of that value, -- (failing if that injected value cannot be projected). extractR :: (Monad m, Injection a g) => Rewrite c m g -> Rewrite c m a extractR = extractWithFailMsgR "extractR failed"@@ -130,7 +130,7 @@ promoteWithFailMsgR msg r = projectWithFailMsgT msg >>> r >>> injectT {-# INLINE promoteWithFailMsgR #-} --- | Promote a 'Rewrite' into over a value into a 'Rewrite' over an injection of that value,+-- | Promote a rewrite over a value into a rewrite over an injection of that value, -- (failing if that injected value cannot be projected). promoteR :: (Monad m, Injection a g) => Rewrite c m a -> Rewrite c m g promoteR = promoteWithFailMsgR "promoteR failed"
Language/KURE/Lens.hs view
@@ -1,7 +1,7 @@ {-# Language InstanceSigs #-} -- | -- Module: Language.KURE.Lens--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -33,50 +33,50 @@ import Control.Arrow import Language.KURE.MonadCatch-import Language.KURE.Translate-import Language.KURE.BiTranslate+import Language.KURE.Transform+import Language.KURE.BiTransform import Language.KURE.Injection-import Language.KURE.Combinators.Translate+import Language.KURE.Combinators.Transform ------------------------------------------------------------------------------------------ -- | 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)}+newtype Lens c m a b = Lens { -- | Convert a 'Lens' into a 'Transform' that produces a sub-structure (and its context) and an unfocussing function.+ lensT :: Transform 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 :: Transform c m a ((c,b), b -> m a) -> Lens c m a b lens = Lens {-# INLINE lens #-} --- | Apply a 'Rewrite' at a point specified by a '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 = do ((c,b),k) <- lensT l- constT (apply r c b >>= k)+ constT (applyR r c b >>= k) {-# INLINE focusR #-} --- | 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+-- | Apply a transformation at a point specified by a 'Lens'.+focusT :: Monad m => Lens c m a b -> Transform c m b d -> Transform c m a d focusT l t = do ((c,b),_) <- lensT l- constT (apply t c b)+ constT (applyT t c b) {-# INLINE focusT #-} -- | 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 :: MonadCatch m => Lens c m a b -> Transform c m a Bool testLensT l = testM (focusR l id) {-# INLINE testLensT #-} instance Monad m => Category (Lens c m) where id :: Lens c m a a- id = lens $ translate $ \ c a -> return ((c,a), return)+ id = lens $ transform $ \ c a -> return ((c,a), return) {-# INLINE id #-} (.) :: 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+ l2 . l1 = lens $ transform $ \ ca a -> do ((cb,b),kb) <- applyT (lensT l1) ca a+ ((cd,d),kd) <- applyT (lensT l2) cb b return ((cd,d),kd >=> kb) {-# INLINE (.) #-} @@ -93,11 +93,11 @@ l1 `catchL` l2 = lens (attemptM (focusR l1 idR) >>= either (lensT . l2) (const (lensT l1))) {-# INLINE catchL #-} --- | Construct a 'Lens' from a 'BiTranslate'.-bidirectionalL :: Monad m => BiTranslate c m a b -> Lens c m a b+-- | Construct a 'Lens' from a 'BiTransform'.+bidirectionalL :: Monad m => BiTransform c m a b -> Lens c m a b bidirectionalL bt = lens $ do c <- contextT b <- forwardT bt- return ((c,b), apply (backwardT bt) c)+ return ((c,b), applyT (backwardT bt) c) {-# INLINE bidirectionalL #-} -- | Construct a 'Lens' from two pure functions.@@ -109,12 +109,12 @@ -- | A 'Lens' to the injection of a value. injectL :: (Monad m, Injection a g) => Lens c m a g-injectL = lens $ translate $ \ c a -> return ((c, inject a), projectM)+injectL = lens $ transform $ \ c a -> return ((c, inject a), projectM) {-# INLINE injectL #-} -- | A 'Lens' to the projection of a value. projectL :: (Monad m, Injection a g) => Lens c m g a-projectL = lens $ translate $ \ c -> projectM >=> (\ a -> return ((c,a), injectM))+projectL = lens $ transform $ \ c -> projectM >=> (\ a -> return ((c,a), injectM)) {-# INLINE projectL #-} -------------------------------------------------------------------------------
Language/KURE/MonadCatch.hs view
@@ -1,7 +1,7 @@ {-# Language InstanceSigs #-} -- | -- Module: Language.KURE.MonadCatch--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>
Language/KURE/Path.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -- | -- Module: Language.KURE.Path--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -41,8 +41,8 @@ import Control.Arrow ((>>^)) -import Language.KURE.Translate-import Language.KURE.Combinators.Translate+import Language.KURE.Transform+import Language.KURE.Combinators.Transform import Language.KURE.Injection -------------------------------------------------------------------------------@@ -116,12 +116,12 @@ absPath :: c -> AbsolutePath crumb -- | Lifted version of 'absPath'.-absPathT :: (ReadPath c crumb, Monad m) => Translate c m a (AbsolutePath crumb)+absPathT :: (ReadPath c crumb, Monad m) => Transform c m a (AbsolutePath crumb) absPathT = contextT >>^ absPath {-# INLINE absPathT #-} -- | Lifted version of 'lastCrumb'.-lastCrumbT :: (ReadPath c crumb, Monad m) => Translate c m a crumb+lastCrumbT :: (ReadPath c crumb, Monad m) => Transform c m a crumb lastCrumbT = contextonlyT (projectWithFailMsgM (fail "lastCrumbT failed: at the root, no crumbs yet.") . lastCrumb . absPath) {-# INLINE lastCrumbT #-}
Language/KURE/Pathfinder.hs view
@@ -2,7 +2,7 @@ -- | -- Module: Language.KURE.Pathfinder--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -16,7 +16,7 @@ -- * 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'.+ -- where @q@ is a transformation 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@@ -37,8 +37,8 @@ import Data.Monoid (mempty) import Language.KURE.MonadCatch-import Language.KURE.Translate-import Language.KURE.Combinators.Translate+import Language.KURE.Transform+import Language.KURE.Combinators.Transform import Language.KURE.Path import Language.KURE.Walker import Language.KURE.ExtendableContext@@ -48,48 +48,48 @@ -- | 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+-- | Apply a transformation that stores a 'LocalPath' in the context (starting at the current node).+withLocalPathT :: Transform (WithLocalPath c crumb) m a b -> Transform 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 :: Monad m => Transform (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)+-- | Return the current 'LocalPath' if the predicate transformation succeeds.+acceptLocalPathT :: Monad m => Transform c m g Bool -> Transform (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 :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Transform c m g Bool -> Transform 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 :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Transform c m g Bool -> Transform 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 :: forall c crumb g m. (Walker (WithLocalPath c crumb) g, MonadCatch m) => Transform c m g Bool -> Transform 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 :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Transform c m g Bool -> Transform 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 :: Monad m => Transform c m [LocalPath crumb] (LocalPath crumb) requireUniquePath = contextfreeT $ \ ps -> case ps of [] -> fail "No matching nodes found." [p] -> return p@@ -97,12 +97,12 @@ {-# 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 :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Transform c m g Bool -> Transform 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 :: (Walker (WithLocalPath c crumb) g, MonadCatch m) => Transform c m g Bool -> Transform c m g (LocalPath crumb) uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath {-# INLINE uniquePrunePathToT #-}
+ Language/KURE/Transform.hs view
@@ -0,0 +1,243 @@+{-# Language InstanceSigs #-}+-- |+-- Module: Language.KURE.Transform+-- Copyright: (c) 2012--2014 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module defines 'Transform' and 'Rewrite', the main KURE types.+-- 'Rewrite' is just a special case of 'Transform', and so any function that operates on 'Transform' is also+-- applicable to 'Rewrite'.+--+-- 'Transform' is an instance of the 'Monad' and 'Arrow' type-class families, and consequently+-- many of the desirable combinators over 'Transform' and 'Rewrite' are special cases+-- of existing monadic or arrow combinators.+-- "Language.KURE.Combinators" provides some additional combinators that aren't in the standard libraries.++module Language.KURE.Transform+ (-- * Transformations and Rewrites+ Transform, Translate+ , Rewrite+ , applyT, applyR, apply+ , transform, translate+ , rewrite+ , contextfreeT+ , contextonlyT+ , constT+) where++import Prelude hiding (id, (.))++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import Control.Category+import Control.Arrow++import Data.Monoid++import Language.KURE.MonadCatch++------------------------------------------------------------------------------------------++-- | 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 'Transform' type is the basis of the entire KURE library.+newtype Transform c m a b = Transform { -- | Apply a transformation to a value and its context.+ applyT :: c -> a -> m b}++-- | A deprecated synonym for 'Transform'.+type Translate c m a b = Transform c m a b++-- | The primitive way of building a transformation.+transform :: (c -> a -> m b) -> Transform c m a b+transform = Transform+{-# INLINE transform #-}++-- | A deprecated synonym for 'transform'.+translate :: (c -> a -> m b) -> Translate c m a b+translate = transform+{-# INLINE translate #-}+{-# DEPRECATED translate "Please use 'transform' instead." #-}++-- | A transformation that shares the same source and target type.+type Rewrite c m a = Transform c m a a++-- | The primitive way of building a rewrite.+rewrite :: (c -> a -> m a) -> Rewrite c m a+rewrite = transform+{-# INLINE rewrite #-}++-- | Apply a rewrite to a value and its context.+applyR :: Rewrite c m a -> c -> a -> m a+applyR = applyT+{-# INLINE applyR #-}++-- | A deprecated synonym for 'applyT'.+apply :: Transform c m a b -> c -> a -> m b+apply = applyT+{-# INLINE apply #-}++------------------------------------------------------------------------------------------++-- | Build a 'Transform' that doesn't depend on the context.+contextfreeT :: (a -> m b) -> Transform c m a b+contextfreeT f = transform (\ _ -> f)+{-# INLINE contextfreeT #-}++-- | Build a 'Transform' that doesn't depend on the value.+contextonlyT :: (c -> m b) -> Transform c m a b+contextonlyT f = transform (\ c _ -> f c)+{-# INLINE contextonlyT #-}++-- | Build a constant 'Transform' from a monadic computation.+constT :: m b -> Transform c m a b+constT = contextfreeT . const+{-# INLINE constT #-}++------------------------------------------------------------------------------------------++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Functor m => Functor (Transform c m a) where++ fmap :: (b -> d) -> Transform c m a b -> Transform c m a d+ fmap f t = transform (\ c -> fmap f . applyT t c)+ {-# INLINE fmap #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Applicative m => Applicative (Transform c m a) where++ pure :: b -> Transform c m a b+ pure = constT . pure+ {-# INLINE pure #-}++ (<*>) :: Transform c m a (b -> d) -> Transform c m a b -> Transform c m a d+ tf <*> tb = transform (\ c a -> applyT tf c a <*> applyT tb c a)+ {-# INLINE (<*>) #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Alternative m => Alternative (Transform c m a) where++ empty :: Transform c m a b+ empty = constT empty+ {-# INLINE empty #-}++ (<|>) :: Transform c m a b -> Transform c m a b -> Transform c m a b+ t1 <|> t2 = transform (\ c a -> applyT t1 c a <|> applyT t2 c a)+ {-# INLINE (<|>) #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Monad m => Monad (Transform c m a) where++ return :: b -> Transform c m a b+ return = constT . return+ {-# INLINE return #-}++ (>>=) :: Transform c m a b -> (b -> Transform c m a d) -> Transform c m a d+ t >>= f = transform $ \ c a -> do b <- applyT t c a+ applyT (f b) c a+ {-# INLINE (>>=) #-}++ fail :: String -> Transform 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 (Transform c m a) where++ catchM :: Transform c m a b -> (String -> Transform c m a b) -> Transform c m a b+ catchM t1 t2 = transform $ \ c a -> applyT t1 c a `catchM` \ msg -> applyT (t2 msg) c a+ {-# INLINE catchM #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadPlus m => MonadPlus (Transform c m a) where++ mzero :: Transform c m a b+ mzero = constT mzero+ {-# INLINE mzero #-}++ mplus :: Transform c m a b -> Transform c m a b -> Transform c m a b+ mplus t1 t2 = transform $ \ c a -> applyT t1 c a `mplus` applyT t2 c a+ {-# INLINE mplus #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadIO m => MonadIO (Transform c m a) where++ liftIO :: IO b -> Transform c m a b+ liftIO = constT . liftIO+ {-# INLINE liftIO #-}++------------------------------------------------------------------------------------------++-- | The 'Kleisli' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => Category (Transform c m) where++ id :: Transform c m a a+ id = contextfreeT return+ {-# INLINE id #-}++ (.) :: Transform c m b d -> Transform c m a b -> Transform c m a d+ t2 . t1 = transform (\ c -> applyT t1 c >=> applyT t2 c)+ {-# INLINE (.) #-}+++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => Arrow (Transform c m) where++ arr :: (a -> b) -> Transform c m a b+ arr f = contextfreeT (return . f)+ {-# INLINE arr #-}++ first :: Transform c m a b -> Transform c m (a,z) (b,z)+ first t = transform $ \ c (a,z) -> liftM (\ b -> (b,z)) (applyT t c a)+ {-# INLINE first #-}++ second :: Transform c m a b -> Transform c m (z,a) (z,b)+ second t = transform $ \ c (z,a) -> liftM (\ b -> (z,b)) (applyT t c a)+ {-# INLINE second #-}++ (***) :: Transform c m a1 b1 -> Transform c m a2 b2 -> Transform c m (a1,a2) (b1,b2)+ t1 *** t2 = transform $ \ c (a,b) -> liftM2 (,) (applyT t1 c a) (applyT t2 c b)+ {-# INLINE (***) #-}++ (&&&) :: Transform c m a b1 -> Transform c m a b2 -> Transform c m a (b1,b2)+ t1 &&& t2 = transform $ \ c a -> liftM2 (,) (applyT t1 c a) (applyT 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 (Transform c m) where++ zeroArrow :: Transform 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 (Transform c m) where++ (<+>) :: Transform c m a b -> Transform c m a b -> Transform 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 (Transform c m) where++ app :: Transform c m (Transform c m a b, a) b+ app = transform (\ c (t,a) -> applyT t c a)+ {-# INLINE app #-}++------------------------------------------------------------------------------------------++-- | Lifting through the 'Monad' and a Reader transformer, where (c,a) is the read-only environment.+instance (Monad m, Monoid b) => Monoid (Transform c m a b) where++ mempty :: Transform c m a b+ mempty = return mempty+ {-# INLINE mempty #-}++ mappend :: Transform c m a b -> Transform c m a b -> Transform c m a b+ mappend = liftM2 mappend+ {-# INLINE mappend #-}++------------------------------------------------------------------------------------------
− Language/KURE/Translate.hs
@@ -1,224 +0,0 @@-{-# Language InstanceSigs #-}--- |--- Module: Language.KURE.Translate--- Copyright: (c) 2012--2013 The University of Kansas--- License: BSD3------ Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>--- Stability: beta--- Portability: ghc------ 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'.------ 'Translate' is an instance of the 'Monad' and 'Arrow' type-class families, and consequently--- many of the desirable combinators over 'Translate' and 'Rewrite' are special cases--- of existing monadic or arrow combinators.--- "Language.KURE.Combinators" provides some additional combinators that aren't in the standard libraries.--module Language.KURE.Translate- (-- * Translations and Rewrites- Translate- , Rewrite- , apply- , translate- , rewrite- , contextfreeT- , contextonlyT- , constT-) where--import Prelude hiding (id, (.))--import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class-import Control.Category-import Control.Arrow--import Data.Monoid--import Language.KURE.MonadCatch------------------------------------------------------------------------------------------------ | 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.-newtype Translate c m a b = Translate { -- | Apply a 'Translate' to a value and its context.- apply :: c -> a -> m b}---- | The primitive way of building a 'Translate'.-translate :: (c -> a -> m b) -> Translate c m a b-translate = Translate-{-# INLINE 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-{-# INLINE rewrite #-}------------------------------------------------------------------------------------------------ | Build a 'Translate' that doesn't depend on the context.-contextfreeT :: (a -> m b) -> Translate c m a b-contextfreeT f = translate (\ _ -> f)-{-# INLINE contextfreeT #-}---- | Build a 'Translate' that doesn't depend on the value.-contextonlyT :: (c -> m b) -> Translate c m a b-contextonlyT f = translate (\ c _ -> f c)-{-# INLINE contextonlyT #-}---- | Build a constant 'Translate' from a monadic computation.-constT :: m b -> Translate c m a b-constT = contextfreeT . const-{-# INLINE constT #-}------------------------------------------------------------------------------------------------ | Lifting through a Reader transformer, where (c,a) is the read-only environment.-instance Functor m => Functor (Translate c m a) where-- fmap :: (b -> d) -> Translate c m a b -> Translate c m a d- fmap f t = translate (\ c -> fmap f . apply t c)- {-# 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 = constT . pure- {-# INLINE pure #-}-- (<*>) :: Translate c m a (b -> d) -> Translate c m a b -> Translate c m a d- tf <*> tb = translate (\ c a -> apply tf c a <*> apply tb c a)- {-# 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 = constT empty- {-# INLINE empty #-}-- (<|>) :: Translate c m a b -> Translate c m a b -> Translate c m a b- t1 <|> t2 = translate (\ c a -> apply t1 c a <|> apply t2 c a)- {-# 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 = constT . return- {-# INLINE return #-}-- (>>=) :: Translate c m a b -> (b -> Translate c m a d) -> Translate c m a d- t >>= f = translate $ \ c a -> do b <- apply t c a- apply (f b) c a- {-# INLINE (>>=) #-}-- 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 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 = constT mzero- {-# INLINE mzero #-}-- mplus :: Translate c m a b -> Translate c m a b -> Translate c m a b- mplus t1 t2 = translate $ \ c a -> apply t1 c a `mplus` apply t2 c a- {-# INLINE mplus #-}---- | Lifting through a Reader transformer, where (c,a) is the read-only environment.-instance MonadIO m => MonadIO (Translate c m a) where-- liftIO :: IO b -> Translate c m a b- liftIO = constT . liftIO- {-# INLINE liftIO #-}------------------------------------------------------------------------------------------------ | The 'Kleisli' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.-instance Monad m => Category (Translate c m) where-- id :: Translate c m a a- id = contextfreeT return- {-# INLINE id #-}-- (.) :: 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 (.) #-}----- | 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)- {-# INLINE arr #-}-- 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 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)- 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)- 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 = 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- (<+>) = 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 (t,a) -> apply t c a)- {-# INLINE app #-}------------------------------------------------------------------------------------------------ | Lifting through the 'Monad' and a Reader transformer, where (c,a) is the read-only environment.-instance (Monad m, Monoid b) => Monoid (Translate c m a b) where-- mempty :: Translate c m a b- mempty = return mempty- {-# INLINE mempty #-}-- mappend :: Translate c m a b -> Translate c m a b -> Translate c m a b- mappend = liftM2 mappend- {-# INLINE mappend #-}--------------------------------------------------------------------------------------------
Language/KURE/Walker.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE InstanceSigs, MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts #-} -- | -- Module: Language.KURE.Walker--- Copyright: (c) 2012--2013 The University of Kansas+-- Copyright: (c) 2012--2014 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -25,7 +25,7 @@ -- * Deep Traversals - -- ** Rewrite Traversals+ -- ** Traversals for Rewrites , alltdR , allbuR , allduR@@ -40,7 +40,7 @@ , anyLargestR , oneLargestR - -- ** Translate Traversals+ -- ** Traversals for Transformations , foldtdT , foldbuT , onetdT@@ -53,7 +53,7 @@ , allLargestT , oneLargestT - -- * Utilitity Translations+ -- * Utilitity Transformations , childrenT , summandIsTypeT @@ -84,7 +84,7 @@ import Control.Category hiding ((.)) import Language.KURE.MonadCatch-import Language.KURE.Translate+import Language.KURE.Transform import Language.KURE.Lens import Language.KURE.Injection import Language.KURE.Combinators@@ -102,26 +102,26 @@ class Walker c g where - -- | Apply a 'Rewrite' to all immediate children, succeeding if they all succeed.+ -- | Apply a rewrite to all immediate children, succeeding if they all succeed. allR :: MonadCatch m => Rewrite c m g -> Rewrite c m g - -- | Apply a 'Translate' to all immediate children, succeeding if they all succeed.+ -- | Apply a transformation to all immediate children, succeeding if they all succeed. -- The results are combined in a 'Monoid'.- allT :: (MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b+ allT :: (MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b allT = unwrapAllT . allR . wrapAllT {-# INLINE allT #-} - -- | Apply a 'Translate' to the first immediate child for which it can succeed.- oneT :: MonadCatch m => Translate c m g b -> Translate c m g b+ -- | Apply a transformation to the first immediate child for which it can succeed.+ oneT :: MonadCatch m => Transform c m g b -> Transform c m g b oneT = unwrapOneT . allR . wrapOneT {-# INLINE oneT #-} - -- | Apply a 'Rewrite' to all immediate children, suceeding if any succeed.+ -- | Apply a rewrite to all immediate children, suceeding if any succeed. anyR :: MonadCatch m => Rewrite c m g -> Rewrite c m g anyR = unwrapAnyR . allR . wrapAnyR {-# INLINE anyR #-} - -- | Apply a 'Rewrite' to the first immediate child for which it can succeed.+ -- | Apply a rewrite to the first immediate child for which it can succeed. oneR :: MonadCatch m => Rewrite c m g -> Rewrite c m g oneR = unwrapOneR . allR . wrapOneR {-# INLINE oneR #-}@@ -134,96 +134,96 @@ ------------------------------------------------------------------------------------------ -- | List the children of the current node.-childrenT :: (ReadPath c crumb, Walker c g, MonadCatch m) => Translate c m g [crumb]+childrenT :: (ReadPath c crumb, Walker c g, MonadCatch m) => Transform c m g [crumb] childrenT = allT (lastCrumbT >>^ return) {-# INLINE childrenT #-} ------------------------------------------------------------------------------- --- | Apply a 'Translate' to a specified child.-childT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> Translate c m g b -> Translate c m g b+-- | Apply a transformation to a specified child.+childT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> Transform c m g b -> Transform c m g b childT n = focusT (childL n) {-# INLINE childT #-} --- | Apply a 'Rewrite' to a specified child.+-- | Apply a rewrite to a specified child. childR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> Rewrite c m g -> Rewrite c m g childR n = focusR (childL n) {-# INLINE childR #-} ------------------------------------------------------------------------------- --- | 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+-- | Fold a tree in a top-down manner, using a single 'Transform' for each node.+foldtdT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b foldtdT t = prefixFailMsg "foldtdT failed: " $ 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+-- | Fold a tree in a bottom-up manner, using a single 'Transform' for each node.+foldbuT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b foldbuT t = prefixFailMsg "foldbuT failed: " $ let go = allT go <> t in go {-# INLINE foldbuT #-} --- | Apply a 'Translate' to the first node for which it can succeed, in a top-down traversal.-onetdT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g b+-- | Apply a transformation to the first node for which it can succeed, in a top-down traversal.+onetdT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform c m g b onetdT t = setFailMsg "onetdT failed" $ let go = t <+ oneT go in go {-# INLINE onetdT #-} --- | Apply a 'Translate' to the first node for which it can succeed, in a bottom-up traversal.-onebuT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g b+-- | Apply a transformation to the first node for which it can succeed, in a bottom-up traversal.+onebuT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform c m g b onebuT t = setFailMsg "onebuT failed" $ let go = oneT go <+ t in go {-# INLINE onebuT #-} --- | Attempt to apply a 'Translate' in a top-down manner, pruning at successes.-prunetdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b+-- | Attempt to apply a 'Transform' in a top-down manner, pruning at successes.+prunetdT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b prunetdT t = setFailMsg "prunetdT failed" $ let go = t <+ allT go in go {-# INLINE prunetdT #-} -- | An always successful top-down fold, replacing failures with 'mempty'.-crushtdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b+crushtdT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b crushtdT t = foldtdT (mtryM t) {-# INLINE crushtdT #-} -- | An always successful bottom-up fold, replacing failures with 'mempty'.-crushbuT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b+crushbuT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b crushbuT t = foldbuT (mtryM t) {-# INLINE crushbuT #-} --- | An always successful traversal that collects the results of all successful applications of a 'Translate' in a list.-collectT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g [b]+-- | An always successful traversal that collects the results of all successful applications of a 'Transform' in a list.+collectT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform c m g [b] collectT t = crushtdT (t >>^ singleton) >>^ toList {-# INLINE collectT #-} -- | Like 'collectT', but does not traverse below successes.-collectPruneT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g [b]+collectPruneT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform c m g [b] collectPruneT t = prunetdT (t >>^ singleton) >>^ toList {-# INLINE collectPruneT #-} ------------------------------------------------------------------------------- --- | Apply a 'Rewrite' in a top-down manner, succeeding if they all succeed.+-- | Apply a rewrite in a top-down manner, succeeding if they all succeed. alltdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g alltdR r = prefixFailMsg "alltdR failed: " $ let go = r >>> allR go in go {-# INLINE alltdR #-} --- | Apply a 'Rewrite' in a bottom-up manner, succeeding if they all succeed.+-- | Apply a rewrite in a bottom-up manner, succeeding if they all succeed. allbuR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g allbuR r = prefixFailMsg "allbuR failed: " $ let go = allR go >>> r in go {-# INLINE allbuR #-} --- | Apply a 'Rewrite' twice, in a top-down and bottom-up way, using one single tree traversal,+-- | 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 g, MonadCatch m) => Rewrite c m g -> Rewrite c m g allduR r = prefixFailMsg "allduR failed: " $@@ -231,21 +231,21 @@ in go {-# INLINE allduR #-} --- | Apply a 'Rewrite' in a top-down manner, succeeding if any succeed.+-- | Apply a rewrite in a top-down manner, succeeding if any succeed. anytdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g anytdR r = setFailMsg "anytdR failed" $ let go = r >+> anyR go in go {-# INLINE anytdR #-} --- | Apply a 'Rewrite' in a bottom-up manner, succeeding if any succeed.+-- | Apply a rewrite in a bottom-up manner, succeeding if any succeed. anybuR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g anybuR r = setFailMsg "anybuR failed" $ let go = anyR go >+> r in go {-# INLINE anybuR #-} --- | Apply a 'Rewrite' twice, in a top-down and bottom-up way, using one single tree traversal,+-- | Apply a rewrite twice, in a top-down and bottom-up way, using one single tree traversal, -- succeeding if any succeed. anyduR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g anyduR r = setFailMsg "anyduR failed" $@@ -253,14 +253,14 @@ in go {-# INLINE anyduR #-} --- | Apply a 'Rewrite' to the first node for which it can succeed, in a top-down traversal.+-- | Apply a rewrite to the first node for which it can succeed, in a top-down traversal. onetdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g onetdR r = setFailMsg "onetdR failed" $ let go = r <+ oneR go in go {-# INLINE onetdR #-} --- | Apply a 'Rewrite' to the first node for which it can succeed, in a bottom-up traversal.+-- | Apply a rewrite to the first node for which it can succeed, in a bottom-up traversal. onebuR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g onebuR r = setFailMsg "onebuR failed" $ let go = oneR go <+ r@@ -310,65 +310,65 @@ ------------------------------------------------------------------------------- --- | Apply a 'Rewrite' at a point specified by a 'Path'.+-- | Apply a rewrite at a point specified by a 'Path'. pathR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Rewrite c m g -> Rewrite c m g pathR = focusR . pathL {-# INLINE pathR #-} --- | Apply a 'Translate' at a point specified by a 'Path'.-pathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Translate c m g b -> Translate c m g b+-- | Apply a transformation at a point specified by a 'Path'.+pathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Transform c m g b -> Transform c m g b pathT = focusT . pathL {-# INLINE pathT #-} --- | Apply a 'Rewrite' at a point specified by a 'LocalPath'.+-- | 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+-- | Apply a transformation at a point specified by a 'LocalPath'.+localPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => LocalPath crumb -> Transform c m g b -> Transform 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.-testPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Translate c m g Bool+testPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Transform c m g Bool testPathT = testLensT . pathL {-# INLINE testPathT #-} ------------------------------------------------------------------------------- --- | Apply a 'Rewrite' to the largest node(s) that satisfy the predicate, requiring all to succeed.-allLargestR :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Rewrite c m g -> Rewrite c m g+-- | Apply a rewrite to the largest node(s) that satisfy the predicate, requiring all to succeed.+allLargestR :: (Walker c g, MonadCatch m) => Transform c m g Bool -> Rewrite c m g -> Rewrite c m g allLargestR p r = prefixFailMsg "allLargestR failed: " $ let go = ifM p r (allR go) in go {-# INLINE allLargestR #-} --- | Apply a 'Rewrite' to the largest node(s) that satisfy the predicate, succeeding if any succeed.-anyLargestR :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Rewrite c m g -> Rewrite c m g+-- | Apply a rewrite to the largest node(s) that satisfy the predicate, succeeding if any succeed.+anyLargestR :: (Walker c g, MonadCatch m) => Transform c m g Bool -> Rewrite c m g -> Rewrite c m g anyLargestR p r = setFailMsg "anyLargestR failed" $ let go = ifM p r (anyR go) in go {-# INLINE anyLargestR #-} --- | Apply a 'Rewrite' to the first node for which it can succeed among the largest node(s) that satisfy the predicate.-oneLargestR :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Rewrite c m g -> Rewrite c m g+-- | Apply a rewrite to the first node for which it can succeed among the largest node(s) that satisfy the predicate.+oneLargestR :: (Walker c g, MonadCatch m) => Transform c m g Bool -> Rewrite c m g -> Rewrite c m g oneLargestR p r = setFailMsg "oneLargestR failed" $ let go = ifM p r (oneR go) in go {-# INLINE oneLargestR #-} --- | Apply a 'Translate' to the largest node(s) that satisfy the predicate, combining the results in a monoid.-allLargestT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g Bool -> Translate c m g b -> Translate c m g b+-- | Apply a transformation to the largest node(s) that satisfy the predicate, combining the results in a monoid.+allLargestT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g Bool -> Transform c m g b -> Transform c m g b allLargestT p t = prefixFailMsg "allLargestT failed: " $ let go = ifM p t (allT go) in go {-# INLINE allLargestT #-} --- | Apply a 'Translate' to the first node for which it can succeed among the largest node(s) that satisfy the predicate.-oneLargestT :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Translate c m g b -> Translate c m g b+-- | Apply a transformation to the first node for which it can succeed among the largest node(s) that satisfy the predicate.+oneLargestT :: (Walker c g, MonadCatch m) => Transform c m g Bool -> Transform c m g b -> Transform c m g b oneLargestT p t = setFailMsg "oneLargestT failed" $ let go = ifM p t (oneT go) in go@@ -376,7 +376,7 @@ -- | Test if the type of the current node summand matches the type of the argument. -- Note that the argument /value/ is never inspected, it is merely a proxy for a type argument.-summandIsTypeT :: forall c m a g. (MonadCatch m, Injection a g) => a -> Translate c m g Bool+summandIsTypeT :: forall c m a g. (MonadCatch m, Injection a g) => a -> Transform c m g Bool summandIsTypeT _ = arr (isJust . (project :: (g -> Maybe a))) {-# INLINE summandIsTypeT #-} @@ -438,13 +438,13 @@ {-# INLINE catchM #-} --- | Wrap a 'Translate' using the 'AllT' monad transformer.-wrapAllT :: Monad m => Translate c m g b -> Rewrite c (AllT b m) g+-- | Wrap a 'Transform' using the 'AllT' monad transformer.+wrapAllT :: Monad m => Transform c m g b -> Rewrite c (AllT b m) g wrapAllT t = readerT $ \ a -> resultT (AllT . liftM (P a)) t {-# INLINE wrapAllT #-} --- | Unwrap a 'Translate' from the 'AllT' monad transformer.-unwrapAllT :: MonadCatch m => Rewrite c (AllT b m) g -> Translate c m g b+-- | Unwrap a 'Transform' from the 'AllT' monad transformer.+unwrapAllT :: MonadCatch m => Rewrite c (AllT b m) g -> Transform c m g b unwrapAllT = prefixFailMsg "allT failed:" . resultT (liftM pSnd . unAllT) {-# INLINE unwrapAllT #-} @@ -495,15 +495,15 @@ {-# INLINE catchM #-} --- | Wrap a 'Translate' using the 'OneT' monad transformer.-wrapOneT :: MonadCatch m => Translate c m g b -> Rewrite c (OneT b m) g+-- | Wrap a 'Transform' using the 'OneT' monad transformer.+wrapOneT :: MonadCatch m => Transform c m g b -> Rewrite c (OneT b m) g wrapOneT t = rewrite $ \ c a -> OneT $ \ mw -> case mw of Just w -> return (P a (Just w))- Nothing -> ((P a . Just) `liftM` apply t c a) <+ return (P a mw)+ Nothing -> ((P a . Just) `liftM` applyT t c a) <+ return (P a mw) {-# INLINE wrapOneT #-} --- | Unwrap a 'Translate' from the 'OneT' monad transformer.-unwrapOneT :: Monad m => Rewrite c (OneT b m) g -> Translate c m g b+-- | Unwrap a 'Transform' from the 'OneT' monad transformer.+unwrapOneT :: Monad m => Rewrite c (OneT b m) g -> Transform c m g b unwrapOneT = resultT (checkSuccessPMaybe "oneT failed" . liftM pSnd . ($ Nothing) . unOneT) {-# INLINE unwrapOneT #-} @@ -563,11 +563,11 @@ rewrite $ \ c a -> GetChild (return a) (if cr == cr' then Just (c, a) else Nothing) {-# INLINE wrapGetChild #-} -unwrapGetChild :: Rewrite c (GetChild c g) g -> Translate c Maybe g (c,g)+unwrapGetChild :: Rewrite c (GetChild c g) g -> Transform c Maybe g (c,g) unwrapGetChild = resultT (\ (GetChild _ mcg) -> mcg) {-# INLINE unwrapGetChild #-} -getChild :: (ReadPath c crumb, Eq crumb, Walker c g) => crumb -> Translate c Maybe g (c, g)+getChild :: (ReadPath c crumb, Eq crumb, Walker c g) => crumb -> Transform c Maybe g (c, g) getChild = unwrapGetChild . allR . wrapGetChild {-# INLINE getChild #-} @@ -595,12 +595,12 @@ k <- setter return (cg, k) where- getter :: Translate c m g (c,g)+ getter :: Transform c m g (c,g) getter = resultT (projectWithFailMsgM "there is no child matching the crumb.") (getChild cr) {-# INLINE getter #-} - setter :: Translate c m g (g -> m g)- setter = translate $ \ c a -> return (\ b -> apply (setChild cr b) c a)+ setter :: Transform c m g (g -> m g)+ setter = transform $ \ c a -> return (\ b -> applyR (setChild cr b) c a) {-# INLINE setter #-} {-# INLINE childL_default #-}
examples/Expr/Examples.hs view
@@ -13,12 +13,12 @@ ----------------------------------------------------------------- type RewriteE a = Rewrite Context KureM a-type TranslateE a b = Translate Context KureM a b+type TransformE a b = Transform Context KureM a b ----------------------------------------------------------------- -applyE :: TranslateE a b -> a -> Either String b-applyE t = runKureM Right Left . apply t initialContext+applyE :: TransformE a b -> a -> Either String b+applyE t = runKureM Right Left . applyT t initialContext ----------------------------------------------------------------- @@ -151,7 +151,7 @@ incrLitGR :: RewriteE Generic incrLitGR = promoteR incrLitR -isExpr :: TranslateE Generic Bool+isExpr :: TransformE Generic Bool isExpr = summandIsTypeT (undefined :: Expr) result4a :: Cmd
examples/Expr/Kure.hs view
@@ -34,8 +34,8 @@ allR :: MonadCatch m => Rewrite c m Generic -> Rewrite c m Generic allR r = prefixFailMsg "allR failed: " $ rewrite $ \ c -> \case- GExpr e -> inject <$> apply allRexpr c e- GCmd cm -> inject <$> apply allRcmd c cm+ GExpr e -> inject <$> applyR allRexpr c e+ GCmd cm -> inject <$> applyR allRcmd c cm where allRexpr = readerT $ \case Add _ _ -> addAllR (extractR r) (extractR r)@@ -48,9 +48,9 @@ --------------------------------------------------------------------------- -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+seqT :: (ExtendPath c Int, AddDef c, Monad m) => Transform c m Cmd a1 -> Transform c m Cmd a2 -> (a1 -> a2 -> b) -> Transform c m Cmd b+seqT t1 t2 f = transform $ \ c -> \case+ Seq cm1 cm2 -> f <$> applyT t1 (c @@ 0) cm1 <*> applyT t2 (updateContextCmd cm1 c @@ 1) cm2 _ -> fail "not a Seq" seqAllR :: (ExtendPath c Int, AddDef c, Monad m) => Rewrite c m Cmd -> Rewrite c m Cmd -> Rewrite c m Cmd@@ -64,9 +64,9 @@ --------------------------------------------------------------------------- -assignT :: (ExtendPath c Int, Monad m) => Translate c m Expr a -> (Name -> a -> b) -> Translate c m Cmd b-assignT t f = translate $ \ c -> \case- Assign n e -> f n <$> apply t (c @@ 0) e+assignT :: (ExtendPath c Int, Monad m) => Transform c m Expr a -> (Name -> a -> b) -> Transform c m Cmd b+assignT t f = transform $ \ c -> \case+ Assign n e -> f n <$> applyT t (c @@ 0) e _ -> fail "not an Assign" assignR :: (ExtendPath c Int, Monad m) => Rewrite c m Expr -> Rewrite c m Cmd@@ -74,23 +74,23 @@ --------------------------------------------------------------------------- -varT :: Monad m => (Name -> b) -> Translate c m Expr b+varT :: Monad m => (Name -> b) -> Transform c m Expr b varT f = contextfreeT $ \case Var v -> return (f v) _ -> fail "not a Var" --------------------------------------------------------------------------- -litT :: Monad m => (Int -> b) -> Translate c m Expr b+litT :: Monad m => (Int -> b) -> Transform c m Expr b 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 -> \case- Add e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2+addT :: (ExtendPath c Int, Monad m) => Transform c m Expr a1 -> Transform c m Expr a2 -> (a1 -> a2 -> b) -> Transform c m Expr b+addT t1 t2 f = transform $ \ c -> \case+ Add e1 e2 -> f <$> applyT t1 (c @@ 0) e1 <*> applyT 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@@ -104,9 +104,9 @@ --------------------------------------------------------------------------- -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+eseqT :: (ExtendPath c Int, AddDef c, Monad m) => Transform c m Cmd a1 -> Transform c m Expr a2 -> (a1 -> a2 -> b) -> Transform c m Expr b+eseqT t1 t2 f = transform $ \ c -> \case+ ESeq cm e1 -> f <$> applyT t1 (c @@ 0) cm <*> applyT t2 (updateContextCmd cm c @@ 1) e1 _ -> fail "not an ESeq" eseqAllR :: (ExtendPath c Int, AddDef c, Monad m) => Rewrite c m Cmd -> Rewrite c m Expr -> Rewrite c m Expr
examples/Fib/Examples.hs view
@@ -9,14 +9,14 @@ ----------------------------------------------------------------------- --- | For this simple example, the context is just an 'AbsolutePath', and 'Translate' always operates on 'Arith'.-type TranslateA b = Translate (AbsolutePath Crumb) KureM Arith b-type RewriteA = TranslateA Arith+-- | For this simple example, the context is just an 'AbsolutePath', and transformations always operates on 'Arith'.+type TransformA b = Transform (AbsolutePath Crumb) KureM Arith b+type RewriteA = TransformA Arith ----------------------------------------------------------------------- -applyFib :: TranslateA b -> Arith -> Either String b-applyFib r = runKureM Right Left . apply r mempty+applyFib :: TransformA b -> Arith -> Either String b+applyFib t = runKureM Right Left . applyT t mempty -----------------------------------------------------------------------
examples/Fib/Kure.hs view
@@ -19,9 +19,9 @@ allR r = prefixFailMsg "allR failed: " $ 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+ Add e0 e1 -> Add <$> applyR r (c @@ LeftChild) e0 <*> applyR r (c @@ RightChild) e1+ Sub e0 e1 -> Sub <$> applyR r (c @@ LeftChild) e0 <*> applyR r (c @@ RightChild) e1+ Fib e0 -> Fib <$> applyR r (c @@ OnlyChild) e0 --------------------------------------------------------------------------------------
examples/Lam/Examples.hs view
@@ -24,17 +24,17 @@ ------------------------------------------------------------------------------- -type TranslateE b = Translate LamC LamM Exp b-type RewriteE = TranslateE Exp+type TransformE b = Transform LamC LamM Exp b+type RewriteE = TransformE Exp ------------------------------------------------------------------------------- -applyExp :: TranslateE b -> Exp -> Either String b-applyExp f = runLamM . apply f initialLamC+applyExp :: TransformE b -> Exp -> Either String b+applyExp t = runLamM . applyT t initialLamC ------------------------------------------------------------------------ -freeVarsT :: TranslateE [Name]+freeVarsT :: TransformE [Name] freeVarsT = fmap nub $ crushbuT $ do (c, Var v) <- exposeT guardM (v `freeIn` c) return [v]
examples/Lam/Kure.hs view
@@ -24,16 +24,16 @@ -- | Congruence combinators. -- Using these ensures that the context is updated consistantly. -varT :: Monad m => (Name -> b) -> Translate c m Exp b+varT :: Monad m => (Name -> b) -> Transform c m Exp b 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 -> \case- Lam v e -> f v <$> apply t (addBoundVar v c @@ Lam_Body) e+lamT :: (ExtendPath c Crumb, AddBoundVar c, Monad m) => Transform c m Exp a -> (Name -> a -> b) -> Transform c m Exp b+lamT t f = transform $ \ c -> \case+ Lam v e -> f v <$> applyT 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@@ -41,9 +41,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 -> \case- App e1 e2 -> f <$> apply t1 (c @@ App_Fun) e1 <*> apply t2 (c @@ App_Arg) e2+appT :: (ExtendPath c Crumb, Monad m) => Transform c m Exp a1 -> Transform c m Exp a2 -> (a1 -> a2 -> b) -> Transform c m Exp b+appT t1 t2 f = transform $ \ c -> \case+ App e1 e2 -> f <$> applyT t1 (c @@ App_Fun) e1 <*> applyT 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
kure.cabal view
@@ -1,5 +1,5 @@ Name: kure-Version: 2.14.6+Version: 2.16.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.@@ -49,11 +49,11 @@ Ghc-Options: -Wall Exposed-modules: Language.KURE- Language.KURE.BiTranslate+ Language.KURE.BiTransform Language.KURE.Combinators Language.KURE.Combinators.Arrow Language.KURE.Combinators.Monad- Language.KURE.Combinators.Translate+ Language.KURE.Combinators.Transform Language.KURE.Debug Language.KURE.ExtendableContext Language.KURE.Injection@@ -61,7 +61,7 @@ Language.KURE.MonadCatch Language.KURE.Path Language.KURE.Pathfinder- Language.KURE.Translate+ Language.KURE.Transform Language.KURE.Walker source-repository head