kure 2.4.10 → 2.6.14
raw patch · 20 files changed
+1665/−1304 lines, 20 files
Files
- Language/KURE.hs +4/−3
- Language/KURE/BiTranslate.hs +65/−0
- Language/KURE/Combinators.hs +10/−249
- Language/KURE/Combinators/Arrow.hs +95/−0
- Language/KURE/Combinators/Monad.hs +51/−0
- Language/KURE/Combinators/Translate.hs +260/−0
- Language/KURE/Debug.hs +24/−0
- Language/KURE/Injection.hs +56/−49
- Language/KURE/Lens.hs +119/−0
- Language/KURE/MonadCatch.hs +171/−0
- Language/KURE/Translate.hs +36/−147
- Language/KURE/Utilities.hs +0/−353
- Language/KURE/Walker.hs +481/−167
- examples/Expr/Examples.hs +74/−16
- examples/Expr/Kure.hs +75/−180
- examples/Fib/Examples.hs +10/−8
- examples/Fib/Kure.hs +19/−26
- examples/Lam/Examples.hs +66/−18
- examples/Lam/Kure.hs +38/−83
- kure.cabal +11/−5
Language/KURE.hs view
@@ -11,15 +11,16 @@ -- The basic transformation functionality can be found in "Language.KURE.Translate", -- and the traversal functionality can be found in "Language.KURE.Walker". ----- Note that "Language.KURE.Injection" and "Language.KURE.Utilities" are not exported here, but can be imported seperately.-- module Language.KURE ( module Language.KURE.Translate , module Language.KURE.Walker , module Language.KURE.Combinators+ , module Language.KURE.MonadCatch+ , module Language.KURE.Injection ) where import Language.KURE.Combinators+import Language.KURE.MonadCatch import Language.KURE.Translate+import Language.KURE.Injection import Language.KURE.Walker
+ Language/KURE/BiTranslate.hs view
@@ -0,0 +1,65 @@+-- |+-- 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 tranlsation that can be applied in either direction.++module Language.KURE.BiTranslate+ ( -- * Bi-directional Translations+ BiTranslate+ , BiRewrite+ , bidirectional+ , forewardT+ , backwardT+ , whicheverR+ , invert+) 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 {forewardT :: Translate c m a b, -- ^ Extract the foreward 'Translate' from a 'BiTranslate'.+ backwardT :: Translate c m b a -- ^ Extract the backward 'Translate' from a 'BiTranslate'.+ }++-- | 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' forewards, then backwards if that fails.+-- Useful when you know which rule you want to apply, but not which direction to apply it in.+whicheverR :: MonadCatch m => BiRewrite c m a -> Rewrite c m a+whicheverR r = forewardT r <+ backwardT r+{-# INLINE whicheverR #-}++-- | Invert the forewards and backwards directions of a 'BiTranslate'.+invert :: BiTranslate c m a b -> BiTranslate c m b a+invert (BiTranslate t1 t2) = BiTranslate t2 t1+{-# INLINE invert #-}++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 (.) #-}++------------------------------------------------------------------------------------------
Language/KURE/Combinators.hs view
@@ -1,263 +1,24 @@-{-# LANGUAGE TupleSections, FlexibleInstances #-}- -- | -- Module: Language.KURE.Combinators--- Copyright: (c) 2012 The University of Kansas+-- Copyright: (c) 2012--2013 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu> -- Stability: beta -- Portability: ghc ----- This module provides various monadic and arrow combinators that are particularly useful when--- working with translations.+-- This module provides various monadic and arrow combinators that are useful when+-- working with 'Translate's and 'Rewrite's. module Language.KURE.Combinators- ( -- * Monad Combinators- -- ** Monads with a Catch- MonadCatch(..)- , (<<+)- , catchesM- , tryM- , mtryM- , attemptM- , testM- , notM- , modFailMsg- , setFailMsg- , prefixFailMsg- , withPatFailMsg- -- ** Conditionals- , guardMsg- , guardM- , ifM- , whenM- , unlessM- -- * Arrow Combinators- -- ** Categories with a Catch- , CategoryCatch(..)- , (<+)- , readerT- , acceptR- , accepterR- , tryR- , attemptR- , changedR- , repeatR- , (>+>)- , orR- , andR- , catchesT- -- ** Basic Routing- -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators.- , result- , argument- , toFst- , toSnd- , swap- , fork- , forkFirst- , forkSecond- , constant+ (+ module Language.KURE.Combinators.Translate+ , module Language.KURE.Combinators.Monad+ , module Language.KURE.Combinators.Arrow ) where -import Prelude hiding (id , (.), foldr)--import Control.Monad-import Control.Category-import Control.Arrow--import Data.Foldable-import Data.Monoid-import Data.List (isPrefixOf)--infixl 3 >+>, <+, <<+------------------------------------------------------------------------------------------------ | 'Monad's with a catch for 'fail'.--- The following law is expected to hold:------ > fail msg `catchM` f == f msg--class Monad m => MonadCatch m where- -- | Catch a failing monadic computation.- catchM :: m a -> (String -> m a) -> m a------------------------------------------------------------------------------------------------ | A monadic catch that ignores the error message.-(<<+) :: MonadCatch m => m a -> m a -> m a-ma <<+ mb = ma `catchM` const mb---- | Select the first monadic computation that succeeds, discarding any thereafter.-catchesM :: (Foldable f, MonadCatch m) => f (m a) -> m a-catchesM = foldr (<<+) (fail "catchesM failed")---- | Catch a failing monadic computation, making it succeed with a constant value.-tryM :: MonadCatch m => a -> m a -> m a-tryM a ma = ma <<+ return a---- | Catch a failing monadic computation, making it succeed with 'mempty'.-mtryM :: (MonadCatch m, Monoid a) => m a -> m a-mtryM = tryM mempty---- | Catch a failing monadic computation, making it succeed with an error message.-attemptM :: MonadCatch m => m a -> m (Either String a)-attemptM ma = liftM Right ma `catchM` (return . Left)---- | Determine if a monadic computation succeeds.-testM :: MonadCatch m => m a -> m Bool-testM ma = liftM (const True) ma <<+ return False---- | Fail if the 'Monad' succeeds; succeed with @()@ if it fails.-notM :: MonadCatch m => m a -> m ()-notM ma = ifM (testM ma) (fail "notM of success") (return ())---- | Modify the error message of a failing monadic computation.--- Successful computations are unaffected.-modFailMsg :: MonadCatch m => (String -> String) -> m a -> m a-modFailMsg f ma = ma `catchM` (fail . f)---- | Set the error message of a failing monadic computation.--- Successful computations are unaffected.-setFailMsg :: MonadCatch m => String -> m a -> m a-setFailMsg msg = modFailMsg (const msg)---- | Add a prefix to the error message of a failing monadic computation.--- Successful computations are unaffected.-prefixFailMsg :: MonadCatch m => String -> m a -> m a-prefixFailMsg msg = modFailMsg (msg ++)---- | Use the given error message whenever a monadic pattern match failure occurs.-withPatFailMsg :: MonadCatch m => String -> m a -> m a-withPatFailMsg msg = modFailMsg (\ e -> if "Pattern match failure" `isPrefixOf` e then msg else e)------------------------------------------------------------------------------------------------ | Similar to 'guard', but invokes 'fail' rather than 'mzero'.-guardMsg :: Monad m => Bool -> String -> m ()-guardMsg b msg = unless b (fail msg)---- | As 'guardMsg', but with a default error message.-guardM :: Monad m => Bool -> m ()-guardM b = guardMsg b "guardM failed"---- | if-then-else lifted over a monadic predicate.-ifM :: Monad m => m Bool -> m a -> m a -> m a-ifM mb m1 m2 = do b <- mb- if b then m1 else m2---- | If the monadic predicate holds then perform the monadic action, else fail.-whenM :: Monad m => m Bool -> m a -> m a-whenM mb ma = ifM mb ma (fail "whenM: condition False")---- | If the monadic predicate holds then fail, else perform the monadic action.-unlessM :: Monad m => m Bool -> m a -> m a-unlessM mb ma = ifM mb (fail "unlessM: condition True") ma------------------------------------------------------------------------------------------------ | 'Category's with failure and catching.--- The following law is expected to hold:------ > failT msg `catchT` f == f msg--class Category arr => CategoryCatch arr where- -- | The failing 'Category'.- failT :: String -> arr a b-- -- | A catch on 'Category's.- catchT :: arr a b -> (String -> arr a b) -> arr a b----- | Left-biased choice.-(<+) :: CategoryCatch arr => arr a b -> arr a b -> arr a b-f <+ g = f `catchT` \ _ -> g---- | Look at the argument to the 'Arrow' before choosing which 'Arrow' to use.-readerT :: ArrowApply arr => (a -> arr a b) -> arr a b-readerT f = (f &&& id) ^>> app---- | Look at the argument to an 'Arrow', and choose to be either the identity arrow or a failure.-acceptR :: (CategoryCatch arr, ArrowApply arr) => (a -> Bool) -> String -> arr a a-acceptR p msg = readerT $ \ a -> if p a then id else failT msg---- | Look at the argument to an 'Arrow', and choose to be either the identity arrow or a failure.--- This is a generalisation of 'acceptR' to any 'Arrow'.-accepterR :: (CategoryCatch arr, ArrowApply arr) => arr a Bool -> String -> arr a a-accepterR t msg = forkFirst t >>> readerT (\ (b,a) -> if b then constant a else failT msg)---- | Catch a failing 'CategoryCatch', making it into an identity.-tryR :: CategoryCatch arr => arr a a -> arr a a-tryR r = r <+ id---- | Catch a failing 'Arrow', making it succeed with a Boolean flag.--- Useful when defining 'Language.KURE.Walker.anyR' instances.-attemptR :: (CategoryCatch arr, Arrow arr) => arr a a -> arr a (Bool,a)-attemptR r = (r >>^ (True,)) <+ arr (False,)---- | Makes an 'Arrow' fail if the result value equals the argument value.-changedR :: (CategoryCatch arr, ArrowApply arr, Eq a) => arr a a -> arr a a-changedR r = readerT (\ a -> r >>> acceptR (/=a) "changedR: value is unchanged")---- | Repeat a 'CategoryCatch' until it fails, then return the result before the failure.--- Requires at least the first attempt to succeed.-repeatR :: CategoryCatch arr => arr a a -> arr a a-repeatR r = r >>> tryR (repeatR r)---- | Attempt two 'Arrow's in sequence, succeeding if one or both succeed.-(>+>) :: (CategoryCatch arr, ArrowApply arr) => arr a a -> arr a a -> arr a a-r1 >+> r2 = attemptR r1 >>> readerT (\ (b,_) -> snd ^>> if b then tryR r2 else r2)---- | Sequence a list of 'Arrow's, succeeding if any succeed.-orR :: (Foldable f, CategoryCatch arr, ArrowApply arr) => f (arr a a) -> arr a a-orR = foldr (>+>) (failT "orR failed")---- | Sequence a list of 'Category's, succeeding if all succeed.-andR :: (Foldable f, Category arr) => f (arr a a) -> arr a a-andR = foldr (>>>) id---- | Select the first 'CategoryCatch' that succeeds, discarding any thereafter.-catchesT :: (Foldable f, CategoryCatch arr) => f (arr a b) -> arr a b-catchesT = foldr (<+) (failT "catchesT failed")+import Language.KURE.Combinators.Monad+import Language.KURE.Combinators.Arrow+import Language.KURE.Combinators.Translate ---------------------------------------------------------------------------------------------- | Apply a pure function to the result of an 'Arrow'.-result :: Arrow arr => (b -> c) -> arr a b -> arr a c-result f a = a >>^ f---- | Apply a pure function to the argument to an 'Arrow'.-argument :: Arrow arr => (a -> b) -> arr b c -> arr a c-argument f a = f ^>> a---- | Apply an 'Arrow' to the first element of a pair, discarding the second element.-toFst :: Arrow arr => arr a b -> arr (a,x) b-toFst f = fst ^>> f---- | Apply an 'Arrow' to the second element of a pair, discarding the first element.-toSnd :: Arrow arr => arr a b -> arr (x,a) b-toSnd f = snd ^>> f---- | A pure 'Arrow' that swaps the elements of a pair.-swap :: Arrow arr => arr (a,b) (b,a)-swap = arr (\(a,b) -> (b,a))---- | A pure 'Arrow' that duplicates its argument.-fork :: Arrow arr => arr a (a,a)-fork = arr (\a -> (a,a))---- | Tag the result of an 'Arrow' with its argument.-forkFirst :: Arrow arr => arr a b -> arr a (b,a)-forkFirst sf = fork >>> first sf---- | Tag the result of an 'Arrow' with its argument.-forkSecond :: Arrow arr => arr a b -> arr a (a,b)-forkSecond sf = fork >>> second sf---- | An arrow with a constant result.-constant :: Arrow arr => b -> arr a b-constant b = arr (const b)---------------------------------------------------------------------------------
+ Language/KURE/Combinators/Arrow.hs view
@@ -0,0 +1,95 @@+-- |+-- Module: Language.KURE.Combinators.Arrow+-- Copyright: (c) 2012--2013 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides some utility arrow routing combinators.++module Language.KURE.Combinators.Arrow+ ( -- * Arrow Routing+ -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators.+ result+ , argument+ , toFst+ , toSnd+ , swap+ , fork+ , forkFirst+ , forkSecond+ , constant+ , serialise+ , parallelise+) where++import Prelude hiding (id, foldr)++import Control.Category hiding ((.))+import Control.Arrow++import Data.Monoid+import Data.Foldable++------------------------------------------------------------------------------------------++-- | 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'.+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.+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.+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.+swap :: Arrow bi => bi (a,b) (b,a)+swap = arr (\(a,b) -> (b,a))+{-# INLINE swap #-}++-- | 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.+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.+forkSecond :: Arrow bi => bi a b -> bi a (a,b)+forkSecond sf = fork >>> second sf+{-# INLINE forkSecond #-}++-- | An arrow with a constant result.+constant :: Arrow bi => b -> bi a b+constant = arr . const+{-# INLINE constant #-}++-------------------------------------------------------------------------------++-- | Sequence (from left to right) a collection of 'Category's.+serialise :: (Foldable f, Category bi) => f (bi a a) -> bi a a+serialise = foldr (>>>) id+{-# INLINE serialise #-}++-- | Apply a collection of 'Arrow's 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 #-}++-------------------------------------------------------------------------------
+ Language/KURE/Combinators/Monad.hs view
@@ -0,0 +1,51 @@+-- |+-- Module: Language.KURE.Combinators.Monad+-- Copyright: (c) 2012--2013 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides conditional monadic combinators.++module Language.KURE.Combinators.Monad+ ( -- * Monadic Conditionals+ guardMsg+ , guardM+ , ifM+ , whenM+ , unlessM+) where++import Control.Monad (unless)++------------------------------------------------------------------------------------------++-- | Similar to 'guard', but invokes 'fail' rather than 'mzero'.+guardMsg :: Monad m => Bool -> String -> m ()+guardMsg b msg = unless b (fail msg)+{-# INLINE guardMsg #-}++-- | As 'guardMsg', but with a default error message.+guardM :: Monad m => Bool -> m ()+guardM b = guardMsg b "guardM failed"+{-# INLINE guardM #-}++-- | if-then-else lifted over a monadic predicate.+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM mb m1 m2 = do b <- mb+ if b then m1 else m2+{-# INLINE ifM #-}++-- | If the monadic predicate holds then perform the monadic action, else fail.+whenM :: Monad m => m Bool -> m a -> m a+whenM mb ma = ifM mb ma (fail "whenM: condition False")+{-# INLINE whenM #-}++-- | If the monadic predicate holds then fail, else perform the monadic action.+unlessM :: Monad m => m Bool -> m a -> m a+unlessM mb ma = ifM mb (fail "unlessM: condition True") ma+{-# INLINE unlessM #-}++------------------------------------------------------------------------------------------
+ Language/KURE/Combinators/Translate.hs view
@@ -0,0 +1,260 @@+-- |+-- 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+ , contextT+ , exposeT+ , readerT+ , resultT+ , catchesT+ , mapT+ , joinT+ , guardT+ -- * Rewrite Combinators+ , tryR+ , andR+ , orR+ , (>+>)+ , repeatR+ , acceptR+ , accepterR+ , changedR+ , 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.Monad (liftM)++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 #-}++-- | 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 #-}++-- | 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 an 'Rewrite', and choose to be either the identity rewrite 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 'Category', making it into an identity.+tryR :: MonadCatch m => Rewrite c m a -> Rewrite c m a+tryR r = r <+ id+{-# INLINE tryR #-}++-- | 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")+{-# 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 '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++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 => 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 => 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
@@ -0,0 +1,24 @@+-- |+-- 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 (unsafe) debugging/tracing combinators.+--+module Language.KURE.Debug (+ debugR+) where++import Debug.Trace++import Language.KURE.Combinators.Translate+import Language.KURE.Translate+++-- | 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/Injection.hs view
@@ -2,28 +2,26 @@ -- | -- Module: Language.KURE.Injection--- Copyright: (c) 2012 The University of Kansas+-- 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 type class for injective functions (and their retractions),+-- This module provides a type class for injective functions (and their projections), -- and some useful interactions with 'Translate'. ----- A particularly useful instance of 'Injection' is from @a@ to 'Generic' @a@,--- and that case is the primary purpose of most of these combinators.- module Language.KURE.Injection ( -- * Injection Class Injection(..) -- * Monad Injections , injectM- , retractM+ , projectM+ , projectWithFailMsgM -- * Translate Injections , injectT- , retractT+ , projectT , extractT , promoteT , promoteWithFailMsgT@@ -32,96 +30,105 @@ , promoteR , extractWithFailMsgR , promoteWithFailMsgR- -- * Lens Injections- , injectL- , retractL ) where -import Control.Monad import Control.Arrow import Language.KURE.Translate-import Language.KURE.Combinators ------------------------------------------------------------------------------- --- | A class of injective functions from @a@ to @b@, and their retractions.+-- | A class of injective functions from @a@ to @b@, and their projections. -- The following law is expected to hold: ----- > retract (inject a) == Just a+-- > project (inject a) == Just a class Injection a b where inject :: a -> b- retract :: b -> Maybe a+ project :: b -> Maybe a -- | There is an identity injection for all types. instance Injection a a where+ {-# INLINE inject #-} inject = id- retract = Just+ {-# INLINE project #-}+ project = Just instance Injection a (Maybe a) where+ {-# INLINE inject #-} inject = Just- retract = id+ {-# INLINE project #-}+ project = id ------------------------------------------------------------------------------- -- | Injects a value and lifts it into a 'Monad'.-injectM :: (Monad m, Injection a a') => a -> m a'+injectM :: (Monad m, Injection a g) => a -> m g injectM = return . inject+{-# INLINE injectM #-} --- | Retracts a value and lifts it into a 'MonadCatch', with the possibility of failure.-retractM :: (MonadCatch m, Injection a a') => a' -> m a-retractM = maybe (fail "retractM failed") return . retract+-- | As 'projectM', but takes a custom error message to use if projection fails.+projectWithFailMsgM :: (Monad m, Injection a g) => String -> g -> m a+projectWithFailMsgM msg = maybe (fail msg) return . project+{-# INLINE projectWithFailMsgM #-} +-- | Projects a value and lifts it into a 'MonadCatch', with the possibility of failure.+projectM :: (Monad m, Injection a g) => g -> m a+projectM = projectWithFailMsgM "projectM failed"+{-# INLINE projectM #-}+ ------------------------------------------------------------------------------- -- | Lifted 'inject'.-injectT :: (Monad m, Injection a a') => Translate c m a a'+injectT :: (Monad m, Injection a g) => Translate c m a g injectT = arr inject+{-# INLINE injectT #-} --- | Lifted 'retract', the 'Translate' fails if the retraction fails.-retractT :: (MonadCatch m, Injection a a') => Translate c m a' a-retractT = contextfreeT retractM+projectWithFailMsgT :: (Monad m, Injection a g) => String -> Translate 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+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 a') => Translate c m a' b -> Translate c m a b+extractT :: (Monad m, Injection a g) => Translate c m g b -> Translate c m a b extractT t = injectT >>> t+{-# INLINE extractT #-} -- | As 'promoteT', but takes a custom error message to use if promotion fails.-promoteWithFailMsgT :: (MonadCatch m, Injection a a') => String -> Translate c m a b -> Translate c m a' b-promoteWithFailMsgT msg t = setFailMsg msg retractT >>> t+promoteWithFailMsgT :: (Monad m, Injection a g) => String -> Translate c m a b -> Translate 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,--- (failing if that injected value cannot be retracted).-promoteT :: (MonadCatch m, Injection a a') => Translate c m a b -> Translate c m a' b+-- (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 = promoteWithFailMsgT "promoteT failed"+{-# INLINE promoteT #-} -- | As 'extractR', but takes a custom error message to use if extraction fails.-extractWithFailMsgR :: (MonadCatch m, Injection a a') => String -> Rewrite c m a' -> Rewrite c m a-extractWithFailMsgR msg r = injectT >>> r >>> setFailMsg msg retractT+extractWithFailMsgR :: (Monad m, Injection a g) => String -> Rewrite c m g -> Rewrite c m a+extractWithFailMsgR msg r = injectT >>> r >>> projectWithFailMsgT msg+{-# INLINE extractWithFailMsgR #-} --- | Convert a 'Rewrite' over an injected value into a 'Rewrite' over a retraction of that value,--- (failing if that injected value cannot be retracted).-extractR :: (MonadCatch m, Injection a a') => Rewrite c m a' -> Rewrite c m a+-- | 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"+{-# INLINE extractR #-} -- | As 'promoteR', but takes a custom error message to use if promotion fails.-promoteWithFailMsgR :: (MonadCatch m, Injection a a') => String -> Rewrite c m a -> Rewrite c m a'-promoteWithFailMsgR msg r = setFailMsg msg retractT >>> r >>> injectT+promoteWithFailMsgR :: (Monad m, Injection a g) => String -> Rewrite c m a -> Rewrite c m g+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,--- (failing if that injected value cannot be retracted).-promoteR :: (MonadCatch m, Injection a a') => Rewrite c m a -> Rewrite c m a'+-- (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"------------------------------------------------------------------------------------- | A 'Lens' to the injection of a value.-injectL :: (MonadCatch m, Injection a a') => Lens c m a a'-injectL = lens $ translate $ \ c a -> return ((c, inject a), retractM)---- | A 'Lens' to the retraction of a value.-retractL :: (MonadCatch m, Injection a a') => Lens c m a' a-retractL = lens $ translate $ \ c -> retractM >=> (\ a -> return ((c,a), injectM))+{-# INLINE promoteR #-} -------------------------------------------------------------------------------
+ Language/KURE/Lens.hs view
@@ -0,0 +1,119 @@+-- |+-- Module: Language.KURE.Lens+-- Copyright: (c) 2012--2013 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module defines the KURE 'Lens' type, along with some useful operations.+--+module Language.KURE.Lens+ ( -- * Lenses+ Lens+ , lens+ , lensT+ , focusR+ , focusT+ , pureL+ , failL+ , catchL+ , testLensT+ , bidirectionalL+ , injectL+ , projectL+) where++import Prelude hiding (id, (.))++import Control.Monad+import Control.Category+import Control.Arrow++import Language.KURE.MonadCatch+import Language.KURE.Translate+import Language.KURE.BiTranslate+import Language.KURE.Injection+import Language.KURE.Combinators.Translate++------------------------------------------------------------------------------------------++-- | A 'Lens' is a way to focus on a sub-structure of type @b@ from a structure of type @a@.+newtype Lens c m a b = Lens { -- | Convert a 'Lens' into a 'Translate' that produces a sub-structure (and its context) and an unfocussing function.+ lensT :: Translate c m a ((c,b), b -> m a)}++-- | The primitive way of building a 'Lens'.+-- If the unfocussing function is applied to the value focussed on then it should succeed,+-- and produce the same value as the original argument (of type @a@).+lens :: Translate c m a ((c,b), b -> m a) -> Lens c m a b+lens = Lens+{-# INLINE 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)+{-# 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+focusT l t = do ((c,b),_) <- lensT l+ constT (apply 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 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)+ {-# 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+ return ((cd,d),kd >=> kb)+ {-# INLINE (.) #-}++-- | The failing 'Lens'.+failL :: Monad m => String -> Lens c m a b+failL = lens . fail+{-# INLINE failL #-}++-- | A 'Lens' is deemed to have failed (and thus can be caught) if either it fails on the way down, or,+-- crucially, if it would fail on the way up for an unmodified value. However, actual failure on the way up is not caught+-- (as by then it is too late to use an alternative 'Lens'). This means that, in theory, a use of 'catch' could cause a succeeding 'Lens' application to fail.+-- But provided 'lens' is used correctly, this should never happen.+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)))+{-# INLINE catchL #-}++-- | Construct a 'Lens' from a 'BiTranslate'.+bidirectionalL :: Monad m => BiTranslate c m a b -> Lens c m a b+bidirectionalL bt = lens $ do c <- contextT+ b <- forewardT bt+ return ((c,b), apply (backwardT bt) c)+{-# INLINE bidirectionalL #-}++-- | Construct a 'Lens' from two pure functions.+pureL :: Monad m => (a -> b) -> (b -> a) -> Lens c m a b+pureL f g = bidirectionalL $ bidirectional (arr f) (arr g)+{-# INLINE pureL #-}++------------------------------------------------------------------------------------------++-- | 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)+{-# 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))+{-# INLINE projectL #-}++-------------------------------------------------------------------------------
+ Language/KURE/MonadCatch.hs view
@@ -0,0 +1,171 @@+-- |+-- Module: Language.KURE.MonadCatch+-- Copyright: (c) 2012--2013 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- Stability: beta+-- Portability: ghc+--+-- This module provides classes for catch-like operations on 'Monad's.++module Language.KURE.MonadCatch+ ( -- * Monads with a Catch+ MonadCatch(..)+ -- ** The KURE Monad+ , KureM+ , runKureM+ , fromKureM+ -- ** Combinators+ , (<+)+ , catchesM+ , tryM+ , mtryM+ , attemptM+ , testM+ , notM+ , modFailMsg+ , setFailMsg+ , prefixFailMsg+ , withPatFailMsg+) where++import Prelude hiding (foldr)++import Control.Applicative+import Control.Monad++import Data.Foldable+import Data.List (isPrefixOf)+import Data.Monoid++import Language.KURE.Combinators.Monad++infixl 3 <+++------------------------------------------------------------------------------------------++-- | 'Monad's with a catch for 'fail'.+-- The following law is expected to hold:+--+-- > fail msg `catchM` f == f msg++class Monad m => MonadCatch m where+ -- | Catch a failing monadic computation.+ catchM :: m a -> (String -> m a) -> m a++------------------------------------------------------------------------------------------++-- | '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'.+-- A major advantage of this is that monadic pattern match failures are caught safely.+data KureM a = Failure String | Success a deriving (Eq, Show)++-- | Eliminator for 'KureM'.+runKureM :: (a -> b) -> (String -> b) -> KureM a -> b+runKureM _ f (Failure msg) = f msg+runKureM s _ (Success a) = s a+{-# INLINE runKureM #-}++-- | Get the value from a 'KureM', providing a function to handle the error case.+fromKureM :: (String -> a) -> KureM a -> a+fromKureM = runKureM id+{-# INLINE fromKureM #-}++instance Monad KureM where+-- return :: a -> KureM a+ return = Success+ {-# INLINE return #-}++-- (>>=) :: KureM a -> (a -> KureM b) -> KureM b+ (Success a) >>= f = f a+ (Failure msg) >>= _ = Failure msg+ {-# INLINE (>>=) #-}++-- fail :: String -> KureM a+ fail = Failure+ {-# INLINE fail #-}++instance MonadCatch KureM where+-- 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 = liftM+ {-# INLINE fmap #-}++instance Applicative KureM where+-- pure :: a -> KureM a+ pure = return+ {-# INLINE pure #-}++-- (<*>) :: KureM (a -> b) -> KureM a -> KureM b+ (<*>) = ap+ {-# INLINE (<*>) #-}++-------------------------------------------------------------------------------++-- | A monadic catch that ignores the error message.+(<+) :: MonadCatch m => m a -> m a -> m a+ma <+ mb = ma `catchM` const mb+{-# INLINE (<+) #-}++-- | Select the first monadic computation that succeeds, discarding any thereafter.+catchesM :: (Foldable f, MonadCatch m) => f (m a) -> m a+catchesM = foldr (<+) (fail "catchesM failed")+{-# INLINE catchesM #-}++-- | Catch a failing monadic computation, making it succeed with a constant value.+tryM :: MonadCatch m => a -> m a -> m a+tryM a ma = ma <+ return a+{-# INLINE tryM #-}++-- | Catch a failing monadic computation, making it succeed with 'mempty'.+mtryM :: (MonadCatch m, Monoid a) => m a -> m a+mtryM = tryM mempty+{-# INLINE mtryM #-}++-- | Catch a failing monadic computation, making it succeed with an error message.+attemptM :: MonadCatch m => m a -> m (Either String a)+attemptM ma = liftM Right ma `catchM` (return . Left)+{-# INLINE attemptM #-}++-- | Determine if a monadic computation succeeds.+testM :: MonadCatch m => m a -> m Bool+testM ma = liftM (const True) ma <+ return False+{-# INLINE testM #-}++-- | Fail if the 'Monad' succeeds; succeed with @()@ if it fails.+notM :: MonadCatch m => m a -> m ()+notM ma = ifM (testM ma) (fail "notM of success") (return ())+{-# INLINE notM #-}++-- | Modify the error message of a failing monadic computation.+-- Successful computations are unaffected.+modFailMsg :: MonadCatch m => (String -> String) -> m a -> m a+modFailMsg f ma = ma `catchM` (fail . f)+{-# INLINE modFailMsg #-}++-- | Set the error message of a failing monadic computation.+-- Successful computations are unaffected.+setFailMsg :: MonadCatch m => String -> m a -> m a+setFailMsg msg = modFailMsg (const msg)+{-# INLINE setFailMsg #-}++-- | Add a prefix to the error message of a failing monadic computation.+-- Successful computations are unaffected.+prefixFailMsg :: MonadCatch m => String -> m a -> m a+prefixFailMsg msg = modFailMsg (msg ++)+{-# INLINE prefixFailMsg #-}++-- | Use the given error message whenever a monadic pattern match failure occurs.+withPatFailMsg :: MonadCatch m => String -> m a -> m a+withPatFailMsg msg = modFailMsg (\ e -> if "Pattern match failure" `isPrefixOf` e then msg else e)+{-# INLINE withPatFailMsg #-}++------------------------------------------------------------------------------------------
Language/KURE/Translate.hs view
@@ -1,23 +1,23 @@ -- | -- Module: Language.KURE.Translate--- Copyright: (c) 2012 The University of Kansas+-- Copyright: (c) 2012--2013 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu> -- Stability: beta -- Portability: ghc ----- This module defines the main KURE types: 'Translate', 'Rewrite' and 'Lens'.+-- This module defines the main KURE types: 'Translate' and 'Rewrite'. -- 'Rewrite' is just a special case of 'Translate', and so any function that operates on 'Translate' is also -- applicable to 'Rewrite'. ----- This module also contains 'Translate' instance declarations for the 'Monad' and 'Arrow' type-class families.--- Given these instances, many of the desirable combinators over 'Translate' and 'Rewrite' are special cases+-- '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+ (-- * Translations and Rewrites Translate , Rewrite , apply@@ -26,40 +26,18 @@ , contextfreeT , contextonlyT , constT- , contextT- , exposeT- , mapT- , sideEffectR- -- * Bi-directional Translations- , BiTranslate- , BiRewrite- , bidirectional- , forewardT- , backwardT- , whicheverR- , invert- -- * Lenses- , Lens- , lens- , lensT- , focusR- , focusT- , testLensT- , bidirectionalL- , pureL ) where -import Prelude hiding (id, (.), mapM)+import Prelude hiding (id, (.)) import Control.Applicative-import Control.Monad hiding (mapM)+import Control.Monad import Control.Category import Control.Arrow -import Data.Traversable import Data.Monoid -import Language.KURE.Combinators+import Language.KURE.MonadCatch ------------------------------------------------------------------------------------------ @@ -68,9 +46,10 @@ 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'.+-- | 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@@ -78,36 +57,24 @@ -- | 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---- | Extract the current context.-contextT :: Monad m => Translate c m a c-contextT = translate (\ c _ -> return c)---- | Expose the current context and value.-exposeT :: Monad m => Translate c m a (c,a)-exposeT = translate (curry return)---- | 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)---- | An identity 'Rewrite' with side-effects.-sideEffectR :: Monad m => (c -> a -> m ()) -> Rewrite c m a-sideEffectR f = translate f >> id+{-# INLINE constT #-} ------------------------------------------------------------------------------------------ @@ -116,53 +83,63 @@ -- 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 #-} ------------------------------------------------------------------------------------------ @@ -171,18 +148,11 @@ -- 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)---- | The 'Kleisli' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.-instance MonadCatch m => CategoryCatch (Translate c m) where---- failT :: String -> Translate c m a b- failT = fail---- catchT :: Translate c m a b -> (String -> Translate c m a b) -> Translate c m a b- catchT = catchM+ {-# INLINE (.) #-} -- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.@@ -190,33 +160,40 @@ -- 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 #-} -- (***) :: 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 #-} ------------------------------------------------------------------------------------------ @@ -225,98 +202,10 @@ -- 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------------------------------------------------------------------------------------------------ | An undirected 'Translate'.-data BiTranslate c m a b = BiTranslate {forewardT :: Translate c m a b, -- ^ Extract the foreward 'Translate' from a 'BiTranslate'.- backwardT :: Translate c m b a -- ^ Extract the backward 'Translate' from a 'BiTranslate'.- }---- | 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---- | Try the 'BiRewrite' forewards, then backwards if that fails.--- Useful when you know which rule you want to apply, but not which direction to apply it in.-whicheverR :: MonadCatch m => BiRewrite c m a -> Rewrite c m a-whicheverR r = forewardT r <+ backwardT r---- | Invert the forewards and backwards directions of a 'BiTranslate'.-invert :: BiTranslate c m a b -> BiTranslate c m b a-invert (BiTranslate t1 t2) = BiTranslate t2 t1--instance Monad m => Category (BiTranslate c m) where--- id :: BiTranslate c m a a- id = bidirectional id 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)------------------------------------------------------------------------------------------------ | A 'Lens' is a way to focus on a sub-structure of type @b@ from a structure of type @a@.-newtype Lens c m a b = Lens { -- | Convert a 'Lens' into a 'Translate' that produces a sub-structure (and its context) and an unfocussing function.- lensT :: Translate c m a ((c,b), b -> m a)}---- | The primitive way of building a 'Lens'.--- If the unfocussing function is applied to the value focussed on then it should succeed,--- and produce the same value as the original argument (of type @a@).-lens :: Translate c m a ((c,b), b -> m a) -> Lens c m a b-lens = Lens---- | Apply a 'Rewrite' at a point specified by a 'Lens'.-focusR :: Monad m => Lens c m a b -> Rewrite c m b -> Rewrite c m a-focusR l r = do ((c,b),k) <- lensT l- constT (apply r c b >>= k)---- | Apply a 'Translate' at a point specified by a 'Lens'.-focusT :: Monad m => Lens c m a b -> Translate c m b d -> Translate c m a d-focusT l t = do ((c,b),_) <- lensT l- constT (apply t c b)---- | Check if the focusing succeeds, and additionally whether unfocussing from an unchanged value would succeed.-testLensT :: MonadCatch m => Lens c m a b -> Translate c m a Bool-testLensT l = testM (focusR l id)--instance Monad m => Category (Lens c m) where---- id :: Lens c m a a- id = lens $ translate $ \ c a -> return ((c,a), return)---- (.) :: Lens c m b d -> Lens c m a b -> Lens c m a d- l2 . l1 = lens $ translate $ \ ca a -> do ((cb,b),kb) <- apply (lensT l1) ca a- ((cd,d),kd) <- apply (lensT l2) cb b- return ((cd,d),kd >=> kb)----- | A 'Lens' is deemed to have failed (and thus can be caught) if either it fails on the way down, or,--- crucially, if it would fail on the way up for an unmodified value. However, actual failure on the way up is not caught--- (as by then it is too late to use an alternative 'Lens'). This means that, in theory, a use of 'catch' could cause a succeeding 'Lens' application to fail.--- But provided 'lens' is used correctly, this should never happen.--instance MonadCatch m => CategoryCatch (Lens c m) where---- failT :: String -> Lens c m a b- failT = lens . fail---- catchT :: Lens c m a b -> (String -> Lens c m a b) -> Lens c m a b- l1 `catchT` l2 = lens (attemptM (focusR l1 id) >>= either (lensT . l2) (const (lensT l1)))---- | Construct a 'Lens' from a 'BiTranslate'.-bidirectionalL :: Monad m => BiTranslate c m a b -> Lens c m a b-bidirectionalL (BiTranslate tf tg) = lens $ do c <- contextT- b <- tf- return ((c,b), apply tg c)---- | Construct a 'Lens' from two pure functions.-pureL :: Monad m => (a -> b) -> (b -> a) -> Lens c m a b-pureL f g = bidirectionalL $ bidirectional (arr f) (arr g)+ {-# INLINE mappend #-} ------------------------------------------------------------------------------------------
− Language/KURE/Utilities.hs
@@ -1,353 +0,0 @@-{-# LANGUAGE TupleSections #-}---- |--- Module: Language.KURE.Utilities--- Copyright: (c) 2012 The University of Kansas--- License: BSD3------ Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>--- Stability: beta--- Portability: ghc------ This module contains various utilities that can be useful to users of KURE, but are not essential.--module Language.KURE.Utilities- ( -- * The KURE Monad- KureM- , runKureM- , fromKureM- -- * Error Messages- , missingChild- -- * Generic Combinators- -- $genericdoc- , allTgeneric- , oneTgeneric- , allRgeneric- , anyRgeneric- , oneRgeneric- , childLgeneric- -- * Attempt Combinators- -- ** anyR Support- -- $attemptAnydoc- , attemptAny2- , attemptAny3- , attemptAny4- , attemptAnyN- , attemptAny1N- -- * oneR Support- -- $attemptOnedoc- , withArgumentT- , attemptOne2- , attemptOne3- , attemptOne4- , attemptOneN- , attemptOne1N- -- * Child Combinators- -- $childLdoc- , childLaux- , childL0of1- , childL0of2- , childL1of2- , childL0of3- , childL1of3- , childL2of3- , childL0of4- , childL1of4- , childL2of4- , childL3of4- , childLMofN-) where--import Prelude hiding (sequence, mapM, or)--import Control.Applicative-import Control.Monad hiding (sequence, mapM)-import Control.Arrow--import Data.Monoid-import Data.Foldable-import Data.Traversable--import Language.KURE.Combinators-import Language.KURE.Translate-import Language.KURE.Walker-import Language.KURE.Injection------------------------------------------------------------------------------------- | 'KureM' is a basic error 'Monad'.--- 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'.--- A major advantage of this is that monadic pattern match failures are caught safely.-data KureM a = Failure String | Success a deriving (Eq, Show)---- | Eliminator for 'KureM'.-runKureM :: (a -> b) -> (String -> b) -> KureM a -> b-runKureM _ f (Failure msg) = f msg-runKureM s _ (Success a) = s a---- | Get the value from a 'KureM', providing a function to handle the error case.-fromKureM :: (String -> a) -> KureM a -> a-fromKureM = runKureM id--instance Monad KureM where--- return :: a -> KureM a- return = Success---- (>>=) :: KureM a -> (a -> KureM b) -> KureM b- (Success a) >>= f = f a- (Failure msg) >>= _ = Failure msg---- fail :: String -> KureM a- fail = Failure---- | 'KureM' is the minimal monad that can be an instance of 'MonadCatch'.-instance MonadCatch KureM where--- catchM :: KureM a -> (String -> KureM a) -> KureM a- (Success a) `catchM` _ = Success a- (Failure msg) `catchM` f = f msg--instance Functor KureM where--- fmap :: (a -> b) -> KureM a -> KureM b- fmap = liftM--instance Applicative KureM where--- pure :: a -> KureM a- pure = return---- (<*>) :: KureM (a -> b) -> KureM a -> KureM b- (<*>) = ap------------------------------------------------------------------------------------------------ $genericdoc--- These functions are to aid with defining 'Walker' instances for the 'Generic' type.--- See the \"Expr\" example.--allTgeneric :: (Walker c m a, Monoid b) => Translate c m (Generic a) b -> c -> a -> m b-allTgeneric t c a = inject `liftM` apply (allT t) c a--oneTgeneric :: Walker c m a => Translate c m (Generic a) b -> c -> a -> m b-oneTgeneric t c a = inject `liftM` apply (oneT t) c a--allRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a)-allRgeneric r c a = inject `liftM` apply (allR r) c a--anyRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a)-anyRgeneric r c a = inject `liftM` apply (anyR r) c a--oneRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a)-oneRgeneric r c a = inject `liftM` apply (oneR r) c a--childLgeneric :: Walker c m a => Int -> c -> a -> m ((c, Generic a), Generic a -> m (Generic a))-childLgeneric n c a = (liftM.second.result.liftM) inject $ apply (lensT $ childL n) c a------------------------------------------------------------------------------------- $attemptAnydoc--- These are useful when defining congruence combinators that succeed if any child rewrite succeeds.--- As well as being generally useful, such combinators are helpful when defining 'anyR' instances.--- See the \"Expr\" example, or the HERMIT package.--attemptAny2' :: Monad m => (a1 -> a2 -> r) -> (Bool,a1) -> (Bool,a2) -> m r-attemptAny2' f (b1,a1) (b2,a2) = if b1 || b2- then return (f a1 a2)- else fail "failed for both children"--attemptAny3' :: Monad m => (a1 -> a2 -> a3 -> r) -> (Bool,a1) -> (Bool,a2) -> (Bool,a3) -> m r-attemptAny3' f (b1,a1) (b2,a2) (b3,a3) = if b1 || b2 || b3- then return (f a1 a2 a3)- else fail "failed for all three children"--attemptAny4' :: Monad m => (a1 -> a2 -> a3 -> a4 -> r) -> (Bool,a1) -> (Bool,a2) -> (Bool,a3) -> (Bool,a4) -> m r-attemptAny4' f (b1,a1) (b2,a2) (b3,a3) (b4,a4) = if b1 || b2 || b3 || b4- then return (f a1 a2 a3 a4)- else fail "failed for all four children"--attemptAnyN' :: (Traversable t, Monad m) => (t a -> b) -> t (Bool,a) -> m b-attemptAnyN' f bas = let (bs,as) = (fmap fst &&& fmap snd) $ bas- in if or bs- then return (f as)- else fail ("failed for all " ++ show (length $ toList bs) ++ " children")--attemptAny1N' :: (Traversable t, Monad m) => (a1 -> t a2 -> r) -> (Bool,a1) -> t (Bool,a2) -> m r-attemptAny1N' f (b,a) bas = let (bs,as) = (fmap fst &&& fmap snd) $ bas- in if b || or bs- then return (f a as)- else fail ("failed for all " ++ show (1 + length (toList bs)) ++ " children")--attemptAny2 :: Monad m => (a1 -> a2 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m r-attemptAny2 f = liftArgument2 (attemptAny2' f)--attemptAny3 :: Monad m => (a1 -> a2 -> a3 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m (Bool,a3) -> m r-attemptAny3 f = liftArgument3 (attemptAny3' f)--attemptAny4 :: Monad m => (a1 -> a2 -> a3 -> a4 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m (Bool,a3) -> m (Bool,a4) -> m r-attemptAny4 f = liftArgument4 (attemptAny4' f)--attemptAnyN :: (Traversable t, Monad m) => (t a -> b) -> t (m (Bool,a)) -> m b-attemptAnyN f = liftArgumentN (attemptAnyN' f)--attemptAny1N :: (Traversable t, Monad m) => (a1 -> t a2 -> r) -> m (Bool,a1) -> t (m (Bool,a2)) -> m r-attemptAny1N f = liftArgument1N (attemptAny1N' f)------------------------------------------------------------------------------------- -- | Catch a failing 'Arrow', making it succeed with an error message, and passing through the argument value.--- -- Useful when defining 'Language.KURE.Walker.oneR' instances.--- attemptT :: MonadCatch m => Translate c m a b -> Translate c m a (Either String b, a)--- attemptT t = forkFirst (attemptM t)---- $attemptOnedoc--- These are useful when defining congruence combinators that succeed if one child rewrite succeeds--- (and the remainder are then discarded).--- As well as being generally useful, such combinators are helpful when defining 'oneR' instances.--- See the \"Expr\" example, or the HERMIT package.---- | Return the monadic result of a 'Translate' and pair it with the argument.-withArgumentT :: Monad m => Translate c m a b -> Translate c m a (m b, a)-withArgumentT t = do (c,a) <- exposeT- return (apply t c a, a)--attemptOne1' :: Monad m => (a -> r) -> (m a, a) -> m r-attemptOne1' f (ma , _) = f `liftM` ma--attemptOne2' :: MonadCatch m => (a -> b -> r) -> (m a, a) -> (m b, b) -> m r-attemptOne2' f (ma , a) mbb@(_ , b) = (do a' <- ma- return (f a' b)- ) <<+ attemptOne1' (f a) mbb--attemptOne3' :: MonadCatch m => (a -> b -> c -> r) -> (m a, a) -> (m b, b) -> (m c, c) -> m r-attemptOne3' f (ma , a) mbb@(_ , b) mcc@(_ , c) = (do a' <- ma- return (f a' b c)- ) <<+ attemptOne2' (f a) mbb mcc--attemptOne4' :: MonadCatch m => (a -> b -> c -> d -> r) -> (m a, a) -> (m b, b) -> (m c, c) -> (m d, d) -> m r-attemptOne4' f (ma , a) mbb@(_ , b) mcc@(_ , c) mdd@(_ , d) = (do a' <- ma- return (f a' b c d)- ) <<+ attemptOne3' (f a) mbb mcc mdd--attemptOne2 :: MonadCatch m => (a -> b -> r) -> m (m a, a) -> m (m b, b) -> m r-attemptOne2 f = liftArgument2 (attemptOne2' f)--attemptOne3 :: MonadCatch m => (a -> b -> c -> r) -> m (m a, a) -> m (m b, b) -> m (m c, c) -> m r-attemptOne3 f = liftArgument3 (attemptOne3' f)--attemptOne4 :: MonadCatch m => (a -> b -> c -> d -> r) -> m (m a, a) -> m (m b, b) -> m (m c, c) -> m (m d, d) -> m r-attemptOne4 f = liftArgument4 (attemptOne4' f)----newtype S s m a = S {runS :: s -> m (a, s)}-instance Monad m => Functor (S s m) where fmap = liftM-instance Monad m => Applicative (S s m) where- {-# INLINE pure #-}- pure = return- {-# INLINE (<*>) #-}- (<*>) = liftM2 ($)-instance Monad m => Monad (S s m) where- {-# INLINE return #-}- return a = S $ \ b -> return (a, b)- {-# INLINE (>>=) #-}- m >>= f = S $ \ b -> runS m b >>= \(a, b') -> runS (f a) b'--attemptOneN :: (Traversable t, MonadCatch m) => (t a -> r) -> t (m (m a, a)) -> m r-attemptOneN f = (>>= final) . flip runS False . mapM each where- each m = S $ \ b -> m >>= \(ma, a) -> if b then return (a, b) else liftM (,True) ma <<+ return (a, b)- final (x, b) = if b then return (f x) else fail "failed for all children"--attemptOne1N :: (Traversable t, MonadCatch m) => (a -> t b -> r) -> m (m a, a) -> t (m (m b, b)) -> m r-attemptOne1N f mmaa mmbbs = do- (ma, a) <- mmaa- mbbs <- sequence mmbbs- ((\a' -> f a' $ fmap snd mbbs) `liftM` ma) <<+ attemptOneN (f a) (fmap return mbbs)------------------------------------------------------------------------------------- | A standard error message for when the child index is out of bounds.--missingChild :: Int -> String-missingChild n = "there is no child number " ++ show n------------------------------------------------------------------------------------- $childLdoc--- These functions are helpful when defining 'childL' instances in combination with congruence combinators.--- See the \"Lam\" and \"Expr\" examples, or the HERMIT package.------ Unfortunately they increase quadratically with the number of fields of the constructor.--- It would be nice if they were further expanded to include the calls of 'id' and 'exposeT';--- however this would create a plethora of additional cases as the number (and positions)--- of interesting children would be additional dimensions.------ Note that the numbering scheme MofN is that N is the number of children (including uninteresting children)--- and M is the index of the chosen child, starting with index 0. Thus M ranges from 0 to (n-1).------ TO DO: use Template Haskell to generate these.------ In the mean time, if you need a few more than provided here, drop me an email and I'll add them.--childLaux :: (MonadCatch m, Node b) => (c,b) -> (b -> a) -> ((c, Generic b), Generic b -> m a)-childLaux cb g = (second inject cb, liftM (inject.g) . retractM)--childL0of1 :: (MonadCatch m, Node b) => (b -> a) -> (c,b) -> ((c, Generic b) , Generic b -> m a)-childL0of1 f cb = childLaux cb f--childL0of2 :: (MonadCatch m, Node b0) => (b0 -> b1 -> a) -> (c,b0) -> b1 -> ((c, Generic b0) , Generic b0 -> m a)-childL0of2 f cb0 b1 = childLaux cb0 (\ b0 -> f b0 b1)--childL1of2 :: (MonadCatch m, Node b1) => (b0 -> b1 -> a) -> b0 -> (c,b1) -> ((c, Generic b1) , Generic b1 -> m a)-childL1of2 f b0 cb1 = childLaux cb1 (\ b1 -> f b0 b1)--childL0of3 :: (MonadCatch m, Node b0) => (b0 -> b1 -> b2 -> a) -> (c,b0) -> b1 -> b2 -> ((c, Generic b0) , Generic b0 -> m a)-childL0of3 f cb0 b1 b2 = childLaux cb0 (\ b0 -> f b0 b1 b2)--childL1of3 :: (MonadCatch m, Node b1) => (b0 -> b1 -> b2 -> a) -> b0 -> (c,b1) -> b2 -> ((c, Generic b1) , Generic b1 -> m a)-childL1of3 f b0 cb1 b2 = childLaux cb1 (\ b1 -> f b0 b1 b2)--childL2of3 :: (MonadCatch m, Node b2) => (b0 -> b1 -> b2 -> a) -> b0 -> b1 -> (c,b2) -> ((c, Generic b2) , Generic b2 -> m a)-childL2of3 f b0 b1 cb2 = childLaux cb2 (\ b2 -> f b0 b1 b2)--childL0of4 :: (MonadCatch m, Node b0) => (b0 -> b1 -> b2 -> b3 -> a) -> (c,b0) -> b1 -> b2 -> b3 -> ((c, Generic b0) , Generic b0 -> m a)-childL0of4 f cb0 b1 b2 b3 = childLaux cb0 (\ b0 -> f b0 b1 b2 b3)--childL1of4 :: (MonadCatch m, Node b1) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> (c,b1) -> b2 -> b3 -> ((c, Generic b1) , Generic b1 -> m a)-childL1of4 f b0 cb1 b2 b3 = childLaux cb1 (\ b1 -> f b0 b1 b2 b3)--childL2of4 :: (MonadCatch m, Node b2) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> b1 -> (c,b2) -> b3 -> ((c, Generic b2) , Generic b2 -> m a)-childL2of4 f b0 b1 cb2 b3 = childLaux cb2 (\ b2 -> f b0 b1 b2 b3)--childL3of4 :: (MonadCatch m, Node b3) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> b1 -> b2 -> (c,b3) -> ((c, Generic b3) , Generic b3 -> m a)-childL3of4 f b0 b1 b2 cb3 = childLaux cb3 (\ b3 -> f b0 b1 b2 b3)--childLMofN :: (MonadCatch m, Node b, Traversable t) => Int -> (t b -> a) -> t (c,b) -> ((c, Generic b) , Generic b -> m a)-childLMofN = \ m f cbs ->- childLaux (toList cbs !! m) $ \ b' -> f $ snd $- mapAccumL (\n (_, b) -> n `seq` (n + 1, if n == m then b' else b)) 0 cbs- -- Rather than using map snd and atIndex (2 traversals), we do both at once with a single traversal---- Modify the value in a traversable at specified index.--- atIndex :: Traversable t => (a -> a) -> Int -> t a -> t a--- atIndex f n = snd . mapAccumL (\ m a -> m `seq` (m + 1, if m == n then f a else a)) 0-----------------------------------------------------------------------------------liftArgument2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c-liftArgument2 f ma mb = join (liftM2 f ma mb)--liftArgument3 :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d-liftArgument3 f ma mb mc = join (liftM3 f ma mb mc)--liftArgument4 :: Monad m => (a -> b -> c -> d -> m e) -> m a -> m b -> m c -> m d -> m e-liftArgument4 f ma mb mc md = join (liftM4 f ma mb mc md)--liftArgumentN :: (Traversable t, Monad m) => (t a -> m b) -> t (m a) -> m b-liftArgumentN f mas = sequence mas >>= f--liftArgument1N :: (Traversable t, Monad m) => (a -> t b -> m c) -> m a -> t (m b) -> m c-liftArgument1N f ma mbs = do a <- ma- bs <- sequence mbs- f a bs---------------------------------------------------------------------------------
Language/KURE/Walker.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} -- | -- Module: Language.KURE.Walker--- Copyright: (c) 2012 The University of Kansas+-- Copyright: (c) 2012--2013 The University of Kansas -- License: BSD3 -- -- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>@@ -15,17 +15,18 @@ -- Deliberately, there is no mechanism for \"ascending\" the tree. module Language.KURE.Walker- ( -- * Nodes- Node(..)- , numChildrenT- , hasChild- , hasChildT-- -- * Tree Walkers- , Walker(..)+ (+ -- * Shallow Traversals - -- * Rewrite Traversals+ -- ** Tree Walkers+ Walker(..)+ -- ** Child Transformations , childR+ , childT++ -- * Deep Traversals++ -- ** Rewrite Traversals , alltdR , allbuR , allduR@@ -36,9 +37,11 @@ , onebuR , prunetdR , innermostR+ , allLargestR+ , anyLargestR+ , oneLargestR - -- * Translate Traversals- , childT+ -- ** Translate Traversals , foldtdT , foldbuT , onetdT@@ -48,17 +51,24 @@ , crushbuT , collectT , collectPruneT+ , allLargestT+ , oneLargestT + -- * Utilitity Translations+ , numChildrenT+ , hasChildT+ , summandIsTypeT+ -- * Paths -- ** Absolute Paths , AbsolutePath , rootAbsPath- , extendAbsPath , PathContext(..) , absPathT -- ** Relative Paths , Path , rootPath+ , rootPathT , pathsToT , onePathToT , oneNonEmptyPathToT@@ -66,7 +76,6 @@ , uniquePathToT , uniquePrunePathToT - -- * Using Paths -- ** Building Lenses from Paths , pathL , exhaustPathL@@ -74,295 +83,317 @@ , rootL -- ** Applying transformations at the end of Paths- , pathR- , pathT+ , pathR+ , pathT -- ** Testing Paths- , testPathT+ , testPathT ) where import Prelude hiding (id) +import Data.Maybe (isJust) import Data.Monoid import Data.List+ import Control.Monad import Control.Arrow import Control.Category hiding ((.)) -import Language.KURE.Combinators+import Language.KURE.MonadCatch import Language.KURE.Translate+import Language.KURE.Lens import Language.KURE.Injection------------------------------------------------------------------------------------------------ | A 'Node' is any node in the tree that you wish to be able to traverse.--class (Injection a (Generic a), Generic a ~ Generic (Generic a)) => Node a where-- -- | 'Generic' is a sum of all the types of the sub-nodes, transitively, of @a@.- -- We use @Generic a ~ a@ to signify that something is its own Generic.- -- Simple expression types might be their own sole 'Generic', more complex examples- -- will have a new datatype for the 'Generic', which will also be an instance of class 'Node'.- type Generic a :: *-- -- | Count the number of immediate child 'Node's.- numChildren :: a -> Int---- | Lifted version of 'numChildren'.-numChildrenT :: (Monad m, Node a) => Translate c m a Int-numChildrenT = arr numChildren---- | Check if a 'Node' has a child of the specified index.-hasChild :: Node a => Int -> a -> Bool-hasChild n a = (0 <= n) && (n < numChildren a)---- | Lifted version of 'hasChild'.-hasChildT :: (Monad m, Node a) => Int -> Translate c m a Bool-hasChildT = arr . hasChild+import Language.KURE.Combinators ------------------------------------------------------------------------------- --- | 'Walker' captures the ability to walk over a tree of 'Node's,--- using a specific context @c@ and a 'MonadCatch' @m@.+-- | 'Walker' captures the ability to walk over a tree containing nodes of type @g@,+-- using a specific context @c@. ----- Minimal complete definition: 'childL'.+-- Minimal complete definition: 'allR'. ----- Default definitions are provided for 'allT', 'oneT', 'allR', 'anyR' and 'oneR', but they may be overridden for efficiency.--- For small numbers of interesting children this will not be an issue, but for a large number,--- say for a list of children, it may be.+-- Default definitions are provided for 'anyR', 'oneR', 'allT', 'oneT', and 'childL',+-- but they may be overridden for efficiency. -class (MonadCatch m, Node a) => Walker c m a where+class Walker c g where - -- | Construct a 'Lens' to the n-th child 'Node'.- childL :: Int -> Lens c m a (Generic a)+ -- | 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 'Generic' 'Translate' to all immediate children, succeeding if they all succeed.+ -- | Apply a 'Translate' to all immediate children, succeeding if they all succeed. -- The results are combined in a 'Monoid'.- allT :: Monoid b => Translate c m (Generic a) b -> Translate c m a b- allT t = modFailMsg ("allT failed: " ++) $- do n <- numChildrenT- mconcat (childrenT n (const t))+ allT :: (MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b+ allT = unwrapAllT . allR . wrapAllT+ {-# INLINE allT #-} - -- | Apply a 'Generic' 'Translate' to the first immediate child for which it can succeed.- oneT :: Translate c m (Generic a) b -> Translate c m a b- oneT t = setFailMsg "oneT failed" $- do n <- numChildrenT- catchesT (childrenT n (const t))+ -- | Apply a 'Translate' to the first immediate child for which it can succeed.+ oneT :: MonadCatch m => Translate c m g b -> Translate c m g b+ oneT = unwrapOneT . allR . wrapOneT+ {-# INLINE oneT #-} - -- | Apply a 'Generic' 'Rewrite' to all immediate children, succeeding if they all succeed.- allR :: Rewrite c m (Generic a) -> Rewrite c m a- allR r = modFailMsg ("allR failed: " ++) $- do n <- numChildrenT- andR (childrenR n (const r))+ -- | 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 'Generic' 'Rewrite' to all immediate children, suceeding if any succeed.- anyR :: Rewrite c m (Generic a) -> Rewrite c m a- anyR r = setFailMsg "anyR failed" $- do n <- numChildrenT- orR (childrenR n (const r))+ -- | 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 #-} - -- | Apply a 'Generic' 'Rewrite' to the first immediate child for which it can succeed.- oneR :: Rewrite c m (Generic a) -> Rewrite c m a- oneR r = setFailMsg "oneR failed" $- do n <- numChildrenT- catchesT (childrenR n (const r))+ -- | Construct a 'Lens' to the n-th child node.+ childL :: MonadCatch m => Int -> Lens c m g g+ childL = childL_default+ {-# INLINE childL #-} +------------------------------------------------------------------------------------------++-- | Count the number of children of the current node.+numChildrenT :: (Walker c g, MonadCatch m) => Translate c m g Int+numChildrenT = getSum `liftM` allT (return $ Sum 1)+{-# INLINE numChildrenT #-}++-- | Determine if the current node has a child of the specified number.+-- Useful when defining custom versions of 'childL'.+hasChildT :: (Walker c g, MonadCatch m) => Int -> Translate c m g Bool+hasChildT n = do c <- numChildrenT+ return (n >= 0 && n < c)+{-# INLINE hasChildT #-}++-------------------------------------------------------------------------------+ -- | Apply a 'Translate' to a specified child.-childT :: Walker c m a => Int -> Translate c m (Generic a) b -> Translate c m a b+childT :: (Walker c g, MonadCatch m) => Int -> Translate c m g b -> Translate c m g b childT n = focusT (childL n)+{-# INLINE childT #-} -- | Apply a 'Rewrite' to a specified child.-childR :: Walker c m a => Int -> Rewrite c m (Generic a) -> Rewrite c m a+childR :: (Walker c g, MonadCatch m) => Int -> Rewrite c m g -> Rewrite c m g childR n = focusR (childL n)--childrenT :: Walker c m a => Int -> (Int -> Translate c m (Generic a) b) -> [Translate c m a b]-childrenT n ts = [ childT i (ts i) | i <- [0..(n-1)] ]--childrenR :: Walker c m a => Int -> (Int -> Rewrite c m (Generic a)) -> [Rewrite c m a]-childrenR n rs = [ childR i (rs i) | i <- [0..(n-1)] ]+{-# INLINE childR #-} ------------------------------------------------------------------------------- --- | Fold a tree in a top-down manner, using a single 'Translate' for each 'Node'.-foldtdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b-foldtdT t = modFailMsg ("foldtdT failed: " ++) $+-- | 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 in go+{-# INLINE foldtdT #-} --- | Fold a tree in a bottom-up manner, using a single 'Translate' for each 'Node'.-foldbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b-foldbuT t = modFailMsg ("foldbuT failed: " ++) $+-- | 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 in go+{-# INLINE foldbuT #-} --- | Apply a 'Translate' to the first 'Node' for which it can succeed, in a top-down traversal.-onetdT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+-- | 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 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 m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b-onebuT t = setFailMsg "onetdT failed" $+-- | 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+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 m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+prunetdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate 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 m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+crushtdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b crushtdT t = foldtdT (mtryM t)+{-# INLINE crushtdT #-} -- | An always successful bottom-up fold, replacing failures with 'mempty'.-crushbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b+crushbuT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate 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 m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) [b]+collectT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g [b] collectT t = crushtdT (t >>^ return)+{-# INLINE collectT #-} -- | Like 'collectT', but does not traverse below successes.-collectPruneT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) [b]+collectPruneT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g [b] collectPruneT t = prunetdT (t >>^ return)+{-# INLINE collectPruneT #-} ------------------------------------------------------------------------------- -- | Apply a 'Rewrite' in a top-down manner, succeeding if they all succeed.-alltdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)-alltdR r = modFailMsg ("alltdR failed: " ++) $+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.-allbuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)-allbuR r = modFailMsg ("allbuR failed: " ++) $+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, -- succeeding if they all succeed.-allduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)-allduR r = modFailMsg ("allduR failed: " ++) $+allduR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g+allduR r = prefixFailMsg "allduR failed: " $ let go = r >>> allR go >>> r in go+{-# INLINE allduR #-} -- | Apply a 'Rewrite' in a top-down manner, succeeding if any succeed.-anytdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+anytdR :: (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.-anybuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+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, -- succeeding if any succeed.-anyduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+anyduR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g anyduR r = setFailMsg "anyduR failed" $ let go = r >+> anyR go >+> r in go+{-# INLINE anyduR #-} --- | Apply a 'Rewrite' to the first 'Node' for which it can succeed, in a top-down traversal.-onetdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+-- | 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.-onebuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)-onebuR r = setFailMsg "onetdR failed" $+-- | 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 in go+{-# INLINE onebuR #-} -- | Attempt to apply a 'Rewrite' in a top-down manner, pruning at successful rewrites.-prunetdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+prunetdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g prunetdR r = setFailMsg "prunetdR failed" $ let go = r <+ anyR go in go+{-# INLINE prunetdR #-} -- | A fixed-point traveral, starting with the innermost term.-innermostR :: (Walker c m a, Generic a ~ a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)+innermostR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g innermostR r = setFailMsg "innermostR failed" $ let go = anybuR (r >>> tryR go) in go+{-# INLINE innermostR #-} ------------------------------------------------------------------------------- -- | A path from the root.-newtype AbsolutePath = AbsolutePath [Int]+newtype AbsolutePath = AbsolutePath [Int] deriving Eq instance Show AbsolutePath where show (AbsolutePath p) = show (reverse p)+ {-# INLINE show #-} -- | The (empty) 'AbsolutePath' to the root. rootAbsPath :: AbsolutePath rootAbsPath = AbsolutePath []+{-# INLINE rootAbsPath #-} --- | Extend an 'AbsolutePath' by one descent.-extendAbsPath :: Int -> AbsolutePath -> AbsolutePath-extendAbsPath n (AbsolutePath ns) = AbsolutePath (n:ns) -- | Contexts that are instances of 'PathContext' contain the current 'AbsolutePath'.--- Any user-defined combinators (typically 'childL' and congruence combinators) should update the 'AbsolutePath' using 'extendAbsPath'.+-- Any user-defined combinators (typically 'allR' and congruence combinators) should update the 'AbsolutePath' using '@@'. class PathContext c where- -- | Find the current path.- contextPath :: c -> AbsolutePath+ -- | Retrieve the current absolute path.+ absPath :: c -> AbsolutePath + -- | Extend the current absolute path by one descent.+ (@@) :: c -> Int -> c+ -- | The simplest instance of 'PathContext' is 'AbsolutePath' itself. instance PathContext AbsolutePath where--- contextPath :: AbsolutePath -> AbsolutePath- contextPath p = p+-- absPath :: AbsolutePath -> AbsolutePath+ absPath = id+ {-# INLINE absPath #-} --- | Find the 'AbsolutePath' to the current 'Node'.+-- (@@) :: AbsolutePath -> Int -> AbsolutePath+ (AbsolutePath ns) @@ n = AbsolutePath (n:ns)+ {-# INLINE (@@) #-}++-- | Lifted version of 'absPath'. absPathT :: (PathContext c, Monad m) => Translate c m a AbsolutePath-absPathT = contextT >>^ contextPath+absPathT = absPath `liftM` contextT+{-# INLINE absPathT #-} ------------------------------------------------------------------------------- --- | A path is a route to descend the tree from an arbitrary 'Node'.+-- | A path is a route to descend the tree from an arbitrary node. type Path = [Int] --- | Convert an 'AbsolutePath' into a 'Path' starting at the root.-rootPath :: AbsolutePath -> Path-rootPath (AbsolutePath p) = reverse p+-- | Retrieve the 'Path' from the root to the current node.+rootPath :: PathContext c => c -> Path+rootPath c = let AbsolutePath p = absPath c+ in reverse p+{-# INLINE rootPath #-} +-- | Lifted version of 'rootPath'.+rootPathT :: (PathContext c, Monad m) => Translate c m a Path+rootPathT = rootPath `liftM` contextT+{-# INLINE rootPathT #-}+ -- Provided the first 'AbsolutePath' is a prefix of the second 'AbsolutePath', -- computes the 'Path' from the end of the first to the end of the second. rmPathPrefix :: AbsolutePath -> AbsolutePath -> Maybe Path rmPathPrefix (AbsolutePath p1) (AbsolutePath p2) = do guard (p1 `isSuffixOf` p2)- return (drop (length p1) (reverse p2))+ return $ drop (length p1) (reverse p2)+{-# INLINE rmPathPrefix #-} --- Construct a 'Path' from the current 'Node' to the end of the given 'AbsolutePath', provided that 'AbsolutePath' passes through the current 'Node'.+-- Construct a 'Path' from the current node to the end of the given 'AbsolutePath', provided that 'AbsolutePath' passes through the current node. abs2pathT :: (PathContext c, Monad m) => AbsolutePath -> Translate c m a Path abs2pathT there = do here <- absPathT maybe (fail "Absolute path does not pass through current node.") return (rmPathPrefix here there)+{-# INLINE abs2pathT #-} --- | Find the 'Path's to every 'Node' that satisfies the predicate.-pathsToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) [Path]-pathsToT q = collectT (acceptR q "pathsToT" >>> absPathT) >>= mapM abs2pathT+-- | Find the 'Path's to every node that satisfies the predicate.+pathsToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path]+pathsToT q = collectT (acceptR q >>> absPathT) >>= mapM abs2pathT+{-# INLINE pathsToT #-} --- | Find the 'Path' to the first 'Node' that satisfies the predicate (in a pre-order traversal).-onePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+-- | Find the 'Path' to the first node that satisfies the predicate (in a pre-order traversal).+onePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path onePathToT q = setFailMsg "No matching nodes found." $- onetdT (acceptR q "pathsToT" >>> absPathT) >>= abs2pathT+ onetdT (acceptR q >>> absPathT) >>= abs2pathT+{-# INLINE onePathToT #-} --- | Find the 'Path' to the first descendent 'Node' that satisfies the predicate (in a pre-order traversal).-oneNonEmptyPathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+-- | Find the 'Path' to the first descendent node that satisfies the predicate (in a pre-order traversal).+oneNonEmptyPathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path oneNonEmptyPathToT q = setFailMsg "No matching nodes found." $- do n <- numChildrenT- catchesT $ childrenT n (\ i -> onePathToT q >>^ (i:))---- | Find the 'Path's to every 'Node' that satisfies the predicate, ignoring 'Node's below successes.-prunePathsToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) [Path]-prunePathsToT q = collectPruneT (acceptR q "pathsToT" >>> absPathT) >>= mapM abs2pathT+ do start <- absPathT+ onetdT (acceptR q >>> absPathT >>> acceptR (/= start)) >>= abs2pathT+{-# INLINE oneNonEmptyPathToT #-} +-- | Find the 'Path's to every node that satisfies the predicate, ignoring nodes below successes.+prunePathsToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path]+prunePathsToT q = collectPruneT (acceptR q >>> absPathT) >>= mapM abs2pathT+{-# INLINE prunePathsToT #-} -- local function used by uniquePathToT and uniquePrunePathToT requireUniquePath :: Monad m => Translate c m [Path] Path@@ -370,47 +401,330 @@ [] -> 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 :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+-- | Find the 'Path' to the node that satisfies the predicate, failing if that does not uniquely identify a node.+uniquePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path 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 'Node's below successes).-uniquePrunePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path+-- | Build a 'Path' to the node that satisfies the predicate, failing if that does not uniquely identify a node (ignoring nodes below successes).+uniquePrunePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path 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 #-}+ -- | Construct a 'Lens' by following a 'Path'.-pathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)-pathL = andR . map childL+pathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g+pathL = serialise . map childL+{-# INLINE pathL #-} --- | Construct a 'Lens' that points to the last 'Node' at which the 'Path' can be followed.-exhaustPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)-exhaustPathL = foldr (\ n l -> tryR (childL n >>> l)) id+-- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed.+exhaustPathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g+exhaustPathL = foldr (\ n l -> tryL (childL n >>> l)) id+{-# INLINE exhaustPathL #-} -- | Repeat as many iterations of the 'Path' as possible.-repeatPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)-repeatPathL p = tryR (pathL p >>> repeatPathL p)+repeatPathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g+repeatPathL p = let go = tryL (pathL p >>> go)+ in go+{-# INLINE repeatPathL #-} -- | Build a 'Lens' from the root to a point specified by an 'AbsolutePath'.-rootL :: (Walker c m a, a ~ Generic a) => AbsolutePath -> Lens c m (Generic a) (Generic a)+rootL :: (Walker c g, MonadCatch m) => AbsolutePath -> Lens c m g g rootL = pathL . rootPath+{-# INLINE rootL #-} ------------------------------------------------------------------------------- -- | Apply a 'Rewrite' at a point specified by a 'Path'.-pathR :: (Walker c m a, a ~ Generic a) => Path -> Rewrite c m (Generic a) -> Rewrite c m (Generic a)+pathR :: (Walker c g, MonadCatch m) => Path -> Rewrite c m g -> Rewrite c m g pathR = focusR . pathL+{-# INLINE pathR #-} -- | Apply a 'Translate' at a point specified by a 'Path'.-pathT :: (Walker c m a, a ~ Generic a) => Path -> Translate c m (Generic a) b -> Translate c m (Generic a) b+pathT :: (Walker c g, MonadCatch m) => Path -> Translate c m g b -> Translate c m g b pathT = focusT . pathL+{-# INLINE pathT #-} ------------------------------------------------------------------------------- --- | Check if it is possible to construct a 'Lens' along this path from the current 'Node'.-testPathT :: (Walker c m a, a ~ Generic a) => Path -> Translate c m a Bool+-- | Check if it is possible to construct a 'Lens' along this path from the current node.+testPathT :: (Walker c g, MonadCatch m) => Path -> Translate 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+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+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+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+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+oneLargestT p t = setFailMsg "oneLargestT failed" $+ let go = ifM p t (oneT go)+ in go+{-# INLINE oneLargestT #-}++-- | 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 _ = arr (isJust . (project :: (g -> Maybe a)))+{-# INLINE summandIsTypeT #-}++-------------------------------------------------------------------------------++data P a b = P a b++pSnd :: P a b -> b+pSnd (P _ b) = b+{-# INLINE pSnd #-}++checkSuccessPMaybe :: Monad m => String -> m (Maybe a) -> m a+checkSuccessPMaybe msg ma = ma >>= projectWithFailMsgM msg+{-# INLINE checkSuccessPMaybe #-}++-------------------------------------------------------------------------------++-- These are used for defining 'allT' in terms of 'allR'.+-- However, they are unlikely to be of use to the KURE user.++newtype AllT w m a = AllT (m (P a w))++unAllT :: AllT w m a -> m (P a w)+unAllT (AllT mw) = mw+{-# INLINE unAllT #-}++instance (Monoid w, Monad m) => Monad (AllT w m) where+-- return :: a -> AllT w m a+ return a = AllT $ return (P a mempty)+ {-# INLINE return #-}++-- fail :: String -> AllT w m a+ fail = AllT . fail+ {-# INLINE fail #-}++-- (>>=) :: 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 ma) f = AllT $ ma `catchM` (unAllT . f)+ {-# INLINE catchM #-}+++-- | Wrap a 'Translate' using the 'AllT' monad transformer.+wrapAllT :: Monad m => Translate 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+unwrapAllT = prefixFailMsg "allT failed:" . resultT (liftM pSnd . unAllT)+{-# INLINE unwrapAllT #-}++-------------------------------------------------------------------------------++-- We could probably build this on top of OneR or AllT++-- These are used for defining 'oneT' in terms of 'allR'.+-- However, they are unlikely to be of use to the KURE user.++newtype OneT w m a = OneT (Maybe w -> m (P a (Maybe w)))++unOneT :: OneT w m a -> Maybe w -> m (P a (Maybe w))+unOneT (OneT f) = f+{-# INLINE unOneT #-}++instance Monad m => Monad (OneT w m) where+-- return :: a -> OneT w m a+ return a = OneT $ \ mw -> return (P a mw)+ {-# INLINE return #-}++-- 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+ 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 g) f = OneT $ \ mw -> g mw `catchM` (($ mw) . unOneT . f)+ {-# INLINE catchM #-}+++-- | Wrap a 'Translate' using the 'OneT' monad transformer.+wrapOneT :: MonadCatch m => Translate 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)+{-# INLINE wrapOneT #-}++-- | Unwrap a 'Translate' from the 'OneT' monad transformer.+unwrapOneT :: Monad m => Rewrite c (OneT b m) g -> Translate c m g b+unwrapOneT = resultT (checkSuccessPMaybe "oneT failed" . liftM pSnd . ($ Nothing) . unOneT)+{-# INLINE unwrapOneT #-}++-------------------------------------------------------------------------------++data PInt a = PInt {-# UNPACK #-} !Int a++secondPInt :: (a -> b) -> PInt a -> PInt b+secondPInt f = \ (PInt i a) -> PInt i (f a)+{-# INLINE secondPInt #-}++-------------------------------------------------------------------------------++-- This is hideous.+-- Admittedly, part of the problem is using MonadCatch. If allR just used Monad, this (and other things) would be much simpler.+-- And currently, the only use of MonadCatch is that it allows the error message to be modified.++-- Failure should not occur, so it doesn't really matter where the KureM monad sits in the GetChild stack.+-- I've arbitrarily made it a local failure.++newtype GetChild c g a = GetChild (Int -> PInt (KureM a, Maybe (c,g)))++unGetChild :: GetChild c g a -> Int -> PInt (KureM a, Maybe (c,g))+unGetChild (GetChild f) = f+{-# INLINE unGetChild #-}++instance Monad (GetChild c g) where+-- return :: a -> GetChild c g a+ return a = GetChild $ \ i -> PInt i (return a, Nothing)+ {-# INLINE return #-}++-- fail :: String -> GetChild c g a+ fail msg = GetChild $ \ i -> PInt i (fail msg, Nothing)+ {-# INLINE fail #-}++-- (>>=) :: GetChild c g a -> (a -> GetChild c g b) -> GetChild c g b+ ma >>= f = GetChild $ \ i0 -> let PInt i1 (kma, mcg) = unGetChild ma i0+ in runKureM (\ a -> (secondPInt.second) (mplus mcg) $ unGetChild (f a) i1)+ (\ msg -> PInt i1 (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+ ma `catchM` f = GetChild $ \ i0 -> let p@(PInt i1 (kma, mcg)) = unGetChild ma i0+ in runKureM (\ _ -> p)+ (\ msg -> (secondPInt.second) (mplus mcg) $ unGetChild (f msg) i1)+ kma+ {-# INLINE catchM #-}+++wrapGetChild :: Int -> Rewrite c (GetChild c g) g+wrapGetChild n = rewrite $ \ c a -> GetChild $ \ m -> PInt (m + 1)+ (return a, if n == m then Just (c, a) else Nothing)+{-# INLINE wrapGetChild #-}++unwrapGetChild :: Rewrite c (GetChild c g) g -> Translate c Maybe g (c,g)+unwrapGetChild r = translate $ \ c a -> let PInt _ (_,mcg) = unGetChild (apply r c a) 0+ in mcg+{-# INLINE unwrapGetChild #-}++getChild :: Walker c g => Int -> Translate c Maybe g (c, g)+getChild = unwrapGetChild . allR . wrapGetChild+{-# INLINE getChild #-}++-------------------------------------------------------------------------------++newtype SetChild a = SetChild (Int -> PInt (KureM a))++unSetChild :: SetChild a -> Int -> PInt (KureM a)+unSetChild (SetChild f) = f+{-# INLINE unSetChild #-}++instance Monad SetChild where+-- return :: a -> SetChild c g a+ return a = SetChild $ \ i -> PInt i (return a)+ {-# INLINE return #-}++-- fail :: String -> SetChild c g a+ fail msg = SetChild $ \ i -> PInt i (fail msg)+ {-# INLINE fail #-}++-- (>>=) :: SetChild c g a -> (a -> SetChild c g b) -> SetChild c g b+ ma >>= f = SetChild $ \ i0 -> let PInt i1 ka = unSetChild ma i0+ in runKureM (\ a -> unSetChild (f a) i1)+ (\ msg -> PInt i1 (fail msg))+ ka+ {-# INLINE (>>=) #-}++instance MonadCatch SetChild where+-- catchM :: SetChild c g a -> (String -> SetChild c g a) -> SetChild c g a+ ma `catchM` f = SetChild $ \ i0 -> let PInt i1 ka = unSetChild ma i0+ in runKureM (\ _ -> PInt i1 ka)+ (\ msg -> unSetChild (f msg) i1)+ ka+ {-# INLINE catchM #-}+++wrapSetChild :: Int -> g -> Rewrite c SetChild g+wrapSetChild n g = contextfreeT $ \ a -> SetChild $ \ m -> PInt (m + 1)+ (return $ if n == m then g else a)+{-# INLINE wrapSetChild #-}++unwrapSetChild :: Monad m => Rewrite c SetChild g -> Rewrite c m g+unwrapSetChild r = rewrite $ \ c a -> let PInt _ ka = unSetChild (apply r c a) 0+ in runKureM return fail ka+{-# INLINE unwrapSetChild #-}++setChild :: (Walker c g, Monad m) => Int -> g -> Rewrite c m g+setChild n = unwrapSetChild . allR . wrapSetChild n+{-# INLINE setChild #-}++-------------------------------------------------------------------------------++childL_default :: forall c m g. (Walker c g, MonadCatch m) => Int -> Lens c m g g+childL_default n = lens $ do cg <- getter+ k <- setter+ return (cg, k)+ where+ getter :: Translate c m g (c,g)+ getter = translate $ \ c a -> maybe (fail $ "there is no child number " ++ show n) return (apply (getChild n) c a)+ {-# INLINE getter #-}++ setter :: Translate c m g (g -> m g)+ setter = translate $ \ c a -> return (\ b -> apply (setChild n b) c a)+ {-# INLINE setter #-}++{-# INLINE childL_default #-} -------------------------------------------------------------------------------
examples/Expr/Examples.hs view
@@ -1,42 +1,50 @@ module Expr.Examples where import Language.KURE-import Language.KURE.Injection import Expr.AST import Expr.Kure ----------------------------------------------------------------- +type RewriteE a = Rewrite Context KureM a+type TranslateE a b = Translate Context KureM a b++-----------------------------------------------------------------++applyE :: TranslateE a b -> a -> Either String b+applyE t = runKureM Right Left . apply t initialContext++-----------------------------------------------------------------+ inlineR :: RewriteE Expr-inlineR = do (c, Var v) <- exposeT+inlineR = withPatFailMsg "only variables can be inlined." $+ do (c, Var v) <- exposeT constT (lookupDef v c) -inlineGR :: RewriteE GenericExpr+inlineGR :: RewriteE Generic inlineGR = promoteR inlineR ----------------------------------------------------------------- +cmd1 :: Cmd+cmd1 = Seq (Assign "m" (Lit 7))+ (Assign "n" (Add (Lit 1) (Lit 2)))+ expr1 :: Expr-expr1 = ESeq (Seq (Assign "m" (Lit 7))- (Assign "n" (Add (Lit 1) (Lit 2)))- )+expr1 = ESeq cmd1 (Add (Var "m") (Var "n") ) result1a :: Expr-result1a = ESeq (Seq (Assign "m" (Lit 7))- (Assign "n" (Add (Lit 1) (Lit 2)))- )+result1a = ESeq cmd1 (Add (Lit 7) (Add (Lit 1) (Lit 2)) ) result1b :: Expr-result1b = ESeq (Seq (Assign "m" (Lit 7))- (Assign "n" (Add (Lit 1) (Lit 2)))- )+result1b = ESeq cmd1 (Add (Lit 7) (Var "n") )@@ -50,10 +58,10 @@ test1c :: Bool test1c = applyE (extractR (onetdR inlineGR)) expr1 == Right result1b +-----------------------------------------------------------------+ expr2 :: Expr-expr2 = ESeq (Seq (Assign "m" (Lit 7))- (Assign "n" (Add (Lit 1) (Lit 2)))- )+expr2 = ESeq cmd1 (Add (Var "m") (Var "x") )@@ -69,6 +77,8 @@ test2 :: Bool test2 = applyE (extractR (anytdR inlineGR)) expr2 == Right result2 +-----------------------------------------------------------------+ expr3 :: Expr expr3 = ESeq (Assign "m" (Lit 7) )@@ -82,12 +92,60 @@ test3b :: Bool test3b = applyE (extractR (onetdR inlineGR)) expr3 == Left "onetdR failed" +test3c :: Bool+test3c = applyE (extractR (alltdR inlineGR)) expr3 == Left "alltdR failed: only variables can be inlined."+ ----------------------------------------------------------------- +cmd4a :: Cmd+cmd4a = Assign "a" (Add (Lit 4) (Lit 5))++cmd4b :: Cmd+cmd4b = Assign "b" (Lit 6)++cmd4c :: Cmd+cmd4c = Assign "c" (Lit 7)++cmd4 :: Cmd+cmd4 = Seq cmd4a (Seq cmd4b cmd4c)++incrLitR :: RewriteE Expr+incrLitR = litT (Lit . succ)++incrLitGR :: RewriteE Generic+incrLitGR = promoteR incrLitR++isExpr :: TranslateE Generic Bool+isExpr = summandIsTypeT (undefined :: Expr)++result4a :: Cmd+result4a = Seq cmd4a+ (Seq (Assign "b" (Lit 7))+ (Assign "c" (Lit 8))+ )++result4b :: Cmd+result4b = Seq cmd4a+ (Seq (Assign "b" (Lit 7))+ cmd4c+ )++test4a :: Bool+test4a = applyE (extractR $ anyLargestR isExpr incrLitGR) cmd4 == Right result4a++test4b :: Bool+test4b = applyE (extractR $ oneLargestR isExpr incrLitGR) cmd4 == Right result4b++test4c :: Bool+test4c = applyE (extractR $ allLargestR isExpr incrLitGR) cmd4 == Left "allLargestR failed: allR failed: allR failed: not a Lit"++-----------------------------------------------------------------+ checkTests :: Bool checkTests = and [ test1a, test1b, test1c , test2- , test3a, test3b+ , test3a, test3b, test3c+ , test4a, test4b, test4c ] -----------------------------------------------------------------
examples/Expr/Kure.hs view
@@ -1,31 +1,25 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Expr.Kure where -import Prelude hiding (id , (.))--import Control.Category-import Control.Applicative--import Data.Monoid+import Control.Monad import Language.KURE-import Language.KURE.Injection-import Language.KURE.Utilities import Expr.AST --- NOTE: allT, oneT, allR, anyR and oneR have been defined just to serve as examples:--- the difference in efficiency with the default instances is negligible.- --------------------------------------------------------------------------- data Context = Context AbsolutePath [(Name,Expr)] -- A list of bindings. -- We assume no shadowing in the language. instance PathContext Context where- contextPath (Context p _) = p+-- absPath :: Context -> AbsolutePath+ absPath (Context p _) = p +-- (@@) :: Context -> Int -> Context+ (Context p defs) @@ n = Context (p @@ n) defs+ addDef :: Name -> Expr -> Context -> Context addDef v e (Context p defs) = Context p ((v,e):defs) @@ -33,229 +27,130 @@ updateContextCmd (Seq c1 c2) = updateContextCmd c2 . updateContextCmd c1 updateContextCmd (Assign v e) = (addDef v e) -(@@) :: Context -> Int -> Context-(Context p defs) @@ n = Context (extendAbsPath n p) defs- initialContext :: Context initialContext = Context rootAbsPath [] -lookupDef :: Name -> Context -> KureM Expr-lookupDef v (Context _ defs) = maybe (fail $ v ++ " not found in context") return $ lookup v defs-------------------------------------------------------------------------------type TranslateE a b = Translate Context KureM a b-type RewriteE a = TranslateE a a--applyE :: TranslateE a b -> a -> Either String b-applyE t = runKureM Right Left . apply t initialContext-------------------------------------------------------------------------------data GenericExpr = GExpr Expr- | GCmd Cmd--instance Node GenericExpr where- type Generic GenericExpr = GenericExpr-- numChildren (GExpr e) = numChildren e- numChildren (GCmd c) = numChildren c+lookupDef :: Monad m => Name -> Context -> m Expr+lookupDef v (Context _ defs) = maybe (fail $ v ++ " not found in context") return (lookup v defs) --------------------------------------------------------------------------- -instance Walker Context KureM GenericExpr where-- childL n = lens $ translate $ \ c g -> case g of- GExpr e -> childLgeneric n c e- GCmd cm -> childLgeneric n c cm-- allT t = translate $ \ c g -> case g of- GExpr e -> allTgeneric t c e- GCmd cm -> allTgeneric t c cm-- oneT t = translate $ \ c g -> case g of- GExpr e -> oneTgeneric t c e- GCmd cm -> oneTgeneric t c cm-- allR r = rewrite $ \ c g -> case g of- GExpr e -> allRgeneric r c e- GCmd cm -> allRgeneric r c cm-- anyR r = rewrite $ \ c g -> case g of- GExpr e -> anyRgeneric r c e- GCmd cm -> anyRgeneric r c cm-- oneR r = rewrite $ \ c g -> case g of- GExpr e -> oneRgeneric r c e- GCmd cm -> oneRgeneric r c cm+data Generic = GExpr Expr+ | GCmd Cmd --------------------------------------------------------------------------- -instance Injection Expr GenericExpr where+instance Injection Expr Generic where inject = GExpr - retract (GExpr e) = Just e- retract _ = Nothing--instance Node Expr where- type Generic Expr = GenericExpr-- numChildren (Add _ _) = 2- numChildren (ESeq _ _) = 2- numChildren (Var _) = 0- numChildren (Lit _) = 0--instance Walker Context KureM Expr where- childL n = lens $- case n of- 0 -> addT exposeT id (childL0of2 Add)- <+ eseqT exposeT id (childL0of2 ESeq)- 1 -> addT id exposeT (childL1of2 Add)- <+ eseqT id exposeT (childL1of2 ESeq)- _ -> fail (missingChild n)-- allT t = varT (\ _ -> mempty)- <+ litT (\ _ -> mempty)- <+ addT (extractT t) (extractT t) mappend- <+ eseqT (extractT t) (extractT t) mappend-- oneT t = addT' (extractT t) (extractT t) (<<+)- <+ eseqT' (extractT t) (extractT t) (<<+)- <+ fail "oneT failed"-- allR r = varT Var- <+ litT Lit- <+ addAllR (extractR r) (extractR r)- <+ eseqAllR (extractR r) (extractR r)-- anyR r = addAnyR (extractR r) (extractR r)- <+ eseqAnyR (extractR r) (extractR r)- <+ fail "anyR failed"-- oneR r = addOneR (extractR r) (extractR r)- <+ eseqOneR (extractR r) (extractR r)- <+ fail "oneR failed"-----------------------------------------------------------------------------+ project (GExpr e) = Just e+ project _ = Nothing -instance Injection Cmd GenericExpr where+instance Injection Cmd Generic where inject = GCmd - retract (GCmd c) = Just c- retract _ = Nothing--instance Node Cmd where- type Generic Cmd = GenericExpr-- numChildren (Seq _ _) = 2- numChildren (Assign _ _) = 1--instance Walker Context KureM Cmd where- childL n = lens $- case n of- 0 -> seqT exposeT id (childL0of2 Seq)- <+ assignT exposeT (childL1of2 Assign)- 1 -> seqT id exposeT (childL1of2 Seq)- <+ fail (missingChild n)- _ -> fail (missingChild n)-- allT t = seqT (extractT t) (extractT t) mappend- <+ assignT (extractT t) (\ _ -> id)-- oneT t = seqT' (extractT t) (extractT t) (<<+)- <+ assignT (extractT t) (\ _ -> id)- <+ fail "oneT failed"+ project (GCmd c) = Just c+ project _ = Nothing - allR r = seqAllR (extractR r) (extractR r)- <+ assignR (extractR r)+--------------------------------------------------------------------------- - anyR r = seqAnyR (extractR r) (extractR r)- <+ assignR (extractR r)- <+ fail "anyR failed"+instance Walker Context Generic where+-- allR :: MonadCatch m => Rewrite Context m Generic -> Rewrite Context m Generic+ allR r = prefixFailMsg "allR failed: " $+ rewrite $ \ c g -> case g of+ GExpr e -> inject <$> apply allRexpr c e+ GCmd cm -> inject <$> apply allRcmd c cm+ where+ allRexpr = readerT $ \ expr -> case expr of+ Add _ _ -> addAllR (extractR r) (extractR r)+ ESeq _ _ -> eseqAllR (extractR r) (extractR r)+ _ -> idR - oneR r = seqOneR (extractR r) (extractR r)- <+ assignR (extractR r)- <+ fail "oneR failed"+ allRcmd = readerT $ \ cmd -> case cmd of+ Seq _ _ -> seqAllR (extractR r) (extractR r)+ Assign _ _ -> assignR (extractR r) --------------------------------------------------------------------------- -seqT' :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (KureM a1 -> KureM a2 -> KureM b) -> TranslateE 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)+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 :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (a1 -> a2 -> b) -> TranslateE Cmd b-seqT t1 t2 f = seqT' t1 t2 (liftA2 f)--seqAllR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd+seqAllR :: Monad m => Rewrite Context m Cmd -> Rewrite Context m Cmd -> Rewrite Context m Cmd seqAllR r1 r2 = seqT r1 r2 Seq -seqAnyR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd-seqAnyR r1 r2 = seqT' (attemptR r1) (attemptR r2) (attemptAny2 Seq)+seqAnyR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Cmd -> Rewrite Context m Cmd+seqAnyR r1 r2 = unwrapAnyR $ seqAllR (wrapAnyR r1) (wrapAnyR r2) -seqOneR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd-seqOneR r1 r2 = seqT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 Seq)+seqOneR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Cmd -> Rewrite Context m Cmd+seqOneR r1 r2 = unwrapOneR $ seqAllR (wrapOneR r1) (wrapOneR r2) --------------------------------------------------------------------------- -assignT :: TranslateE Expr a -> (Name -> a -> b) -> TranslateE Cmd b+assignT :: Monad m => Translate Context m Expr a -> (Name -> a -> b) -> Translate Context 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" -assignR :: RewriteE Expr -> RewriteE Cmd+assignR :: Monad m => Rewrite Context m Expr -> Rewrite Context m Cmd assignR r = assignT r Assign --------------------------------------------------------------------------- -varT :: (Name -> b) -> TranslateE Expr b+varT :: Monad m => (Name -> b) -> Translate Context m Expr b varT f = contextfreeT $ \ e -> case e of- Var v -> pure (f v)+ Var v -> return (f v) _ -> fail "not a Var" --------------------------------------------------------------------------- -litT :: (Int -> b) -> TranslateE Expr b+litT :: Monad m => (Int -> b) -> Translate Context m Expr b litT f = contextfreeT $ \ e -> case e of- Lit v -> pure (f v)+ Lit v -> return (f v) _ -> fail "not a Lit" --------------------------------------------------------------------------- -addT' :: TranslateE Expr a1 -> TranslateE Expr a2 -> (KureM a1 -> KureM a2 -> KureM b) -> TranslateE 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 :: TranslateE Expr a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b-addT t1 t2 f = addT' t1 t2 (liftA2 f)+addT :: Monad m => Translate Context m Expr a1 -> Translate Context m Expr a2 -> (a1 -> a2 -> b) -> Translate Context 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" -addAllR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr+addAllR :: Monad m => Rewrite Context m Expr -> Rewrite Context m Expr -> Rewrite Context m Expr addAllR r1 r2 = addT r1 r2 Add -addAnyR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr-addAnyR r1 r2 = addT' (attemptR r1) (attemptR r2) (attemptAny2 Add)+addAnyR :: MonadCatch m => Rewrite Context m Expr -> Rewrite Context m Expr -> Rewrite Context m Expr+addAnyR r1 r2 = unwrapAnyR $ addAllR (wrapAnyR r1) (wrapAnyR r2) -addOneR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr-addOneR r1 r2 = addT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 Add)+addOneR :: MonadCatch m => Rewrite Context m Expr -> Rewrite Context m Expr -> Rewrite Context m Expr+addOneR r1 r2 = unwrapOneR $ addAllR (wrapOneR r1) (wrapOneR r2) --------------------------------------------------------------------------- -eseqT' :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (KureM a1 -> KureM a2 -> KureM b) -> TranslateE 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 :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b-eseqT t1 t2 f = eseqT' t1 t2 (liftA2 f)+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" -eseqAllR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr+eseqAllR :: Monad m => Rewrite Context m Cmd -> Rewrite Context m Expr -> Rewrite Context m Expr eseqAllR r1 r2 = eseqT r1 r2 ESeq -eseqAnyR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr-eseqAnyR r1 r2 = eseqT' (attemptR r1) (attemptR r2) (attemptAny2 ESeq)+eseqAnyR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Expr -> Rewrite Context m Expr+eseqAnyR r1 r2 = unwrapAnyR $ eseqAllR (wrapAnyR r1) (wrapAnyR r2) -eseqOneR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr-eseqOneR r1 r2 = eseqT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 ESeq)+eseqOneR :: MonadCatch m => Rewrite Context m Cmd -> Rewrite Context m Expr -> Rewrite Context m Expr+eseqOneR r1 r2 = unwrapOneR $ eseqAllR (wrapOneR r1) (wrapOneR r2)++---------------------------------------------------------------------------++-- I find it annoying that Applicative is not a superclass of Monad.+(<$>) :: Monad m => (a -> b) -> m a -> m b+(<$>) = liftM+{-# INLINE (<$>) #-}++(<*>) :: Monad m => m (a -> b) -> m a -> m b+(<*>) = ap+{-# INLINE (<*>) #-} ---------------------------------------------------------------------------
examples/Fib/Examples.hs view
@@ -1,16 +1,18 @@ module Fib.Examples where -import Prelude hiding (id , (.), snd)-import Control.Category- import Language.KURE-import Language.KURE.Utilities(runKureM) import Fib.AST-import Fib.Kure+import Fib.Kure() ----------------------------------------------------------------------- +-- | For this simple example, the context is just an 'AbsolutePath', and 'Translate' always operates on 'Arith'.+type TranslateA b = Translate AbsolutePath KureM Arith b+type RewriteA = TranslateA Arith++-----------------------------------------------------------------------+ applyFib :: RewriteA -> Arith -> Either String Arith applyFib r = runKureM Right Left . apply r rootAbsPath @@ -20,7 +22,7 @@ -- Requires the argument to Fib to be a Literal. fibLitR :: RewriteA fibLitR = withPatFailMsg "fibLitR failed: not of form Fib (Lit n)" $- do Fib (Lit n) <- id+ do Fib (Lit n) <- idR case n of 0 -> return (Lit 0) 1 -> return (Lit 1)@@ -31,13 +33,13 @@ -- | Compute the addition of two literals. addLitR :: RewriteA addLitR = withPatFailMsg "addLitR failed" $- do Add (Lit m) (Lit n) <- id+ do Add (Lit m) (Lit n) <- idR return (Lit (m + n)) -- | Compute the subtraction of two literals. subLitR :: RewriteA subLitR = withPatFailMsg "subLitR failed" $- do Sub (Lit m) (Lit n) <- id+ do Sub (Lit m) (Lit n) <- idR return (Lit (m - n)) -----------------------------------------------------------------------
examples/Fib/Kure.hs view
@@ -1,40 +1,33 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Fib.Kure where import Language.KURE-import Language.KURE.Utilities(KureM,missingChild) import Fib.AST ------------------------------------------------------------------------------------------- | For this simple example, the context is just an 'AbsolutePath', and 'Translate' always operates on 'Arith'.-type TranslateA b = Translate AbsolutePath KureM Arith b-type RewriteA = TranslateA Arith+import Control.Monad(liftM, ap) -------------------------------------------------------------------------------------- -instance Node Arith where- type Generic Arith = Arith+instance Walker AbsolutePath Arith where+-- allR :: MonadCatch m => Rewrite AbsolutePath m Arith -> Rewrite AbsolutePath 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 @@ 0) e0 <*> apply r (c @@ 1) e1+ Sub e0 e1 -> Sub <$> apply r (c @@ 0) e0 <*> apply r (c @@ 1) e1+ Fib e0 -> Fib <$> apply r (c @@ 0) e0 - numChildren (Lit _) = 0- numChildren (Add _ _) = 2- numChildren (Sub _ _) = 2- numChildren (Fib _) = 1+-------------------------------------------------------------------------------------- -instance Walker AbsolutePath KureM Arith where+-- I find it annoying that Applicative is not a superclass of Monad.+(<$>) :: Monad m => (a -> b) -> m a -> m b+(<$>) = liftM+{-# INLINE (<$>) #-} - childL n = lens $ translate $ \ c e ->- do guardMsg (hasChild n e) (missingChild n)- let c' = extendAbsPath n c- case e of- Add e1 e2 -> case n of- 0 -> return ((c',e1), \ e1' -> return (Add e1' e2))- 1 -> return ((c',e2), \ e2' -> return (Add e1 e2'))- Sub e1 e2 -> case n of- 0 -> return ((c',e1), \ e1' -> return (Sub e1' e2))- 1 -> return ((c',e2), \ e2' -> return (Sub e1 e2'))- Fib e1 -> case n of- 0 -> return ((c',e1), \ e1' -> return (Fib e1'))+(<*>) :: Monad m => m (a -> b) -> m a -> m b+(<*>) = ap+{-# INLINE (<*>) #-} --------------------------------------------------------------------------------------
examples/Lam/Examples.hs view
@@ -1,19 +1,67 @@ module Lam.Examples where -import Prelude hiding (id, (.))- import Language.KURE import Lam.AST import Lam.Kure import Data.List (nub)-import Control.Arrow-import Control.Category +import Control.Applicative+import Control.Monad+import Control.Category ((>>>))++-----------------------------------------------------------------++newtype LamM a = LamM {lamM :: Int -> (Int, Either String a)}++runLamM :: LamM a -> Either String a+runLamM m = snd (lamM m 0)++instance Monad LamM where+ return a = LamM (\n -> (n,Right a))+ (LamM f) >>= gg = LamM $ \ n -> case f n of+ (n', Left msg) -> (n', Left msg)+ (n', Right a) -> lamM (gg a) n'+ fail msg = LamM (\ n -> (n, Left msg))++instance MonadCatch LamM where++ (LamM 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 = liftM++instance Applicative LamM where+ pure = return+ (<*>) = ap++-------------------------------------------------------------------------------++suggestName :: LamM Name+suggestName = LamM (\n -> ((n+1), Right (show n)))++freshName :: [Name] -> LamM Name+freshName vs = do v <- suggestName+ if v `elem` vs+ then freshName vs+ else return v++-------------------------------------------------------------------------------++type RewriteE = RewriteExp LamM+type TranslateE b = TranslateExp LamM b++-------------------------------------------------------------------------------++applyExp :: TranslateE b -> Exp -> Either String b+applyExp f = runLamM . apply f initialContext+ ------------------------------------------------------------------------ -freeVarsT :: TranslateExp [Name]+freeVarsT :: TranslateE [Name] freeVarsT = fmap nub $ crushbuT $ do (c, Var v) <- exposeT guardM (v `freeIn` c) return [v]@@ -22,57 +70,57 @@ freeVars = either error id . applyExp freeVarsT -- Only works for lambdas, fails for all others-alphaLam :: [Name] -> RewriteExp-alphaLam frees = do Lam v e <- id+alphaLam :: [Name] -> RewriteE+alphaLam frees = do Lam v e <- idR v' <- constT $ freshName $ frees ++ v : freeVars e lamT (tryR $ substExp v (Var v')) (\ _ -> Lam v') -substExp :: Name -> Exp -> RewriteExp+substExp :: Name -> Exp -> RewriteE substExp v s = rules_var <+ rules_lam <+ rule_app where -- From Lambda Calc Textbook, the 6 rules. rules_var = whenM (varT (==v)) (return s) -- Rule 1 - rules_lam = do Lam n e <- id+ rules_lam = do Lam n e <- idR guardM (n /= v) -- Rule 3 guardM (v `elem` freeVars e) -- Rule 4a if n `elem` freeVars s then alphaLam (freeVars s) >>> rules_lam -- Rule 5 else lamR (substExp v s) -- Rule 4b - rule_app = do App _ _ <- id+ rule_app = do App _ _ <- idR anyR (substExp v s) -- Rule 6 ------------------------------------------------------------------------ -beta_reduce :: RewriteExp+beta_reduce :: RewriteE beta_reduce = withPatFailMsg "Cannot beta-reduce, not app-lambda." $- do App (Lam v _) e2 <- id+ do App (Lam v _) e2 <- idR pathT [0,0] (tryR $ substExp v e2) -eta_expand :: RewriteExp+eta_expand :: RewriteE eta_expand = rewrite $ \ c f -> do v <- freshName (bindings c) return $ Lam v (App f (Var v)) -eta_reduce :: RewriteExp+eta_reduce :: RewriteE eta_reduce = withPatFailMsg "Cannot eta-reduce, not lambda-app-var." $- do Lam v1 (App f (Var v2)) <- id+ do Lam v1 (App f (Var v2)) <- idR guardMsg (v1 == v2) $ "Cannot eta-reduce, " ++ v1 ++ " /= " ++ v2 return f -- This might not actually be normal order evaluation -- Contact the KURE maintainer if you can correct this definition.-normal_order_eval :: RewriteExp+normal_order_eval :: RewriteE normal_order_eval = anytdR (repeatR beta_reduce) -- This might not actually be applicative order evaluation -- Contact the KURE maintainer if you can correct this definition.-applicative_order_eval :: RewriteExp+applicative_order_eval :: RewriteE applicative_order_eval = innermostR beta_reduce ------------------------------------------------------------------------ -type LamTest = (RewriteExp,String,Exp,Maybe Exp)+type LamTest = (RewriteE, String, Exp, Maybe Exp) runLamTest :: LamTest -> (Bool, String) runLamTest (r,_,e,me) = case (applyExp r e , me) of
examples/Lam/Kure.hs view
@@ -1,15 +1,10 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Lam.Kure where -import Prelude hiding (id, (.))--import Control.Applicative-import Control.Category import Control.Monad import Language.KURE-import Language.KURE.Utilities import Lam.AST @@ -18,14 +13,15 @@ data Context = Context AbsolutePath [Name] -- bound variable names instance PathContext Context where- contextPath (Context p _) = p+-- absPath :: Context -> AbsolutePath+ absPath (Context p _) = p +-- (@@) :: Context -> Int -> Context+ (Context p vs) @@ n = Context (p @@ n) vs+ addBinding :: Name -> Context -> Context addBinding v (Context p vs) = Context p (v:vs) -(@@) :: Context -> Int -> Context-(Context p vs) @@ n = Context (extendAbsPath n p) vs- initialContext :: Context initialContext = Context rootAbsPath [] @@ -40,105 +36,64 @@ ------------------------------------------------------------------------------- -newtype LamM a = LamM {lamM :: Int -> (Int, Either String a)}--runLamM :: LamM a -> Either String a-runLamM m = snd (lamM m 0)--instance Monad LamM where- return a = LamM (\n -> (n,Right a))- (LamM f) >>= gg = LamM $ \ n -> case f n of- (n', Left msg) -> (n', Left msg)- (n', Right a) -> lamM (gg a) n'- fail msg = LamM (\ n -> (n, Left msg))--instance MonadCatch LamM where- (LamM f) `catchM` g = LamM $ \ n -> case f n of- (n', Left msg) -> lamM (g msg) n'- (n', Right a) -> (n', Right a)--instance Functor LamM where- fmap = liftM--instance Applicative LamM where- pure = return- (<*>) = ap-----------------------------------------------------------------------------------suggestName :: LamM Name-suggestName = LamM (\n -> ((n+1), Right (show n)))--freshName :: [Name] -> LamM Name-freshName vs = do v <- suggestName- if v `elem` vs- then freshName vs- else return v-----------------------------------------------------------------------------------type TranslateExp b = Translate Context LamM Exp b-type RewriteExp = TranslateExp Exp--applyExp :: TranslateExp b -> Exp -> Either String b-applyExp f = runLamM . apply f initialContext+type TranslateExp m b = Translate Context m Exp b+type RewriteExp m = TranslateExp m Exp ------------------------------------------------------------------------------- -instance Node Exp where- type Generic Exp = Exp -- Exp is its own Generic-- numChildren (Var _) = 0- numChildren (Lam _ _) = 1- numChildren (App _ _) = 2--instance Walker Context LamM Exp where- childL n = lens $- case n of- 0 -> appT exposeT id (childL0of2 App)- <+ lamT exposeT (childL1of2 Lam)-- 1 -> appT id exposeT (childL1of2 App)-- _ -> fail (missingChild n)+instance Walker Context Exp where+-- allR :: MonadCatch m => RewriteExp m -> RewriteExp m+ allR r = prefixFailMsg "allR failed: " $+ readerT $ \ e -> case e of+ App _ _ -> appAllR r r+ Lam _ _ -> lamR r+ _ -> idR ------------------------------------------------------------------------------- -- | Congruence combinators. -- Using these ensures that the context is updated consistantly. -varT :: (Name -> b) -> TranslateExp b+varT :: Monad m => (Name -> b) -> TranslateExp m b varT f = contextfreeT $ \ e -> case e of Var n -> return (f n) _ -> fail "no match for Var" ------------------------------------------------------------------------------- -lamT :: TranslateExp a -> (Name -> a -> b) -> TranslateExp b+lamT :: Monad m => TranslateExp m a -> (Name -> a -> b) -> TranslateExp m b lamT t f = translate $ \ c e -> case e of Lam v e1 -> f v <$> apply t (addBinding v c @@ 0) e1 _ -> fail "no match for Lam" -lamR :: RewriteExp -> RewriteExp+lamR :: Monad m => RewriteExp m -> RewriteExp m lamR r = lamT r Lam ------------------------------------------------------------------------------- -appT' :: TranslateExp a1 -> TranslateExp a2 -> (LamM a1 -> LamM a2 -> LamM b) -> TranslateExp b-appT' t1 t2 f = translate $ \ c e -> case e of- App e1 e2 -> f (apply t1 (c @@ 0) e1) (apply t2 (c @@ 1) e2)- _ -> fail "no match for App"--appT :: TranslateExp a1 -> TranslateExp a2 -> (a1 -> a2 -> b) -> TranslateExp b-appT t1 t2 f = appT' t1 t2 (liftA2 f)+appT :: Monad m => TranslateExp m a1 -> TranslateExp m a2 -> (a1 -> a2 -> b) -> TranslateExp m b+appT t1 t2 f = translate $ \ c e -> case e of+ App e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2+ _ -> fail "no match for App" -appAllR :: RewriteExp -> RewriteExp -> RewriteExp+appAllR :: Monad m => RewriteExp m -> RewriteExp m -> RewriteExp m appAllR r1 r2 = appT r1 r2 App -appAnyR :: RewriteExp -> RewriteExp -> RewriteExp-appAnyR r1 r2 = appT' (attemptR r1) (attemptR r2) (attemptAny2 App)+appAnyR :: MonadCatch m => RewriteExp m -> RewriteExp m -> RewriteExp m+appAnyR r1 r2 = unwrapAnyR $ appAllR (wrapAnyR r1) (wrapAnyR r2) -appOneR :: RewriteExp -> RewriteExp -> RewriteExp-appOneR r1 r2 = appT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 App)+appOneR :: MonadCatch m => RewriteExp m -> RewriteExp m -> RewriteExp m+appOneR r1 r2 = unwrapOneR $ appAllR (wrapOneR r1) (wrapOneR r2)++-------------------------------------------------------------------------------++-- I find it annoying that Applicative is not a superclass of Monad.+(<$>) :: Monad m => (a -> b) -> m a -> m b+(<$>) = liftM+{-# INLINE (<$>) #-}++(<*>) :: Monad m => m (a -> b) -> m a -> m b+(<*>) = ap+{-# INLINE (<*>) #-} -------------------------------------------------------------------------------
kure.cabal view
@@ -1,12 +1,12 @@ Name: kure-Version: 2.4.10+Version: 2.6.14 Synopsis: Combinators for Strategic Programming Description: The Kansas University Rewrite Engine (KURE) is a DSL for strategic rewriting. KURE shares concepts with Stratego, but unlike Stratego, KURE is strongly typed. KURE is similar to StrategyLib, but has a lightweight generic traversal mechanism using type families rather than SYB. The basic transformation functionality can be found in "Language.KURE.Translate",- and the traversal functionality can be found in "Language.KURE.Walker".+ and the traversal functionality can be found in "Language.KURE.Walker". Several basic examples of using KURE are provided in the source-code bundle. For a larger example, see the HERMIT package. @@ -15,7 +15,7 @@ License-file: LICENSE Author: Neil Sculthorpe and Andy Gill Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>-Copyright: (c) 2012 The University of Kansas+Copyright: (c) 2012--2013 The University of Kansas Homepage: http://www.ittc.ku.edu/csdl/fpg/Tools/KURE Stability: beta build-type: Simple@@ -37,11 +37,17 @@ Ghc-Options: -Wall Exposed-modules: Language.KURE+ Language.KURE.BiTranslate Language.KURE.Combinators- Language.KURE.Translate+ Language.KURE.Combinators.Arrow+ Language.KURE.Combinators.Monad+ Language.KURE.Combinators.Translate+ Language.KURE.Debug Language.KURE.Injection+ Language.KURE.Lens+ Language.KURE.MonadCatch+ Language.KURE.Translate Language.KURE.Walker- Language.KURE.Utilities