diff --git a/Language/KURE.hs b/Language/KURE.hs --- a/Language/KURE.hs +++ b/Language/KURE.hs @@ -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 diff --git a/Language/KURE/BiTranslate.hs b/Language/KURE/BiTranslate.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/BiTranslate.hs @@ -0,0 +1,65 @@ +-- | +-- Module: Language.KURE.BiTranslate +-- Copyright: (c) 2012--2013 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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 (.) #-} + +------------------------------------------------------------------------------------------ diff --git a/Language/KURE/Combinators.hs b/Language/KURE/Combinators.hs --- a/Language/KURE/Combinators.hs +++ b/Language/KURE/Combinators.hs @@ -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 -- 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) - -------------------------------------------------------------------------------- diff --git a/Language/KURE/Combinators/Arrow.hs b/Language/KURE/Combinators/Arrow.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Combinators/Arrow.hs @@ -0,0 +1,95 @@ +-- | +-- Module: Language.KURE.Combinators.Arrow +-- Copyright: (c) 2012--2013 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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 #-} + +------------------------------------------------------------------------------- diff --git a/Language/KURE/Combinators/Monad.hs b/Language/KURE/Combinators/Monad.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Combinators/Monad.hs @@ -0,0 +1,51 @@ +-- | +-- Module: Language.KURE.Combinators.Monad +-- Copyright: (c) 2012--2013 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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 #-} + +------------------------------------------------------------------------------------------ diff --git a/Language/KURE/Combinators/Translate.hs b/Language/KURE/Combinators/Translate.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Combinators/Translate.hs @@ -0,0 +1,260 @@ +-- | +-- Module: Language.KURE.Combinators.Translate +-- Copyright: (c) 2012--2013 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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 #-} + +------------------------------------------------------------------------------- diff --git a/Language/KURE/Debug.hs b/Language/KURE/Debug.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Debug.hs @@ -0,0 +1,24 @@ +-- | +-- Module: Language.KURE.Combinators.Translate +-- Copyright: (c) 2012--2013 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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) diff --git a/Language/KURE/Injection.hs b/Language/KURE/Injection.hs --- a/Language/KURE/Injection.hs +++ b/Language/KURE/Injection.hs @@ -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 -- 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 #-} ------------------------------------------------------------------------------- diff --git a/Language/KURE/Lens.hs b/Language/KURE/Lens.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Lens.hs @@ -0,0 +1,119 @@ +-- | +-- Module: Language.KURE.Lens +-- Copyright: (c) 2012--2013 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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 #-} + +------------------------------------------------------------------------------- diff --git a/Language/KURE/MonadCatch.hs b/Language/KURE/MonadCatch.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/MonadCatch.hs @@ -0,0 +1,171 @@ +-- | +-- Module: Language.KURE.MonadCatch +-- Copyright: (c) 2012--2013 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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 #-} + +------------------------------------------------------------------------------------------ diff --git a/Language/KURE/Translate.hs b/Language/KURE/Translate.hs --- a/Language/KURE/Translate.hs +++ b/Language/KURE/Translate.hs @@ -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 -- 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 #-} ------------------------------------------------------------------------------------------ diff --git a/Language/KURE/Utilities.hs b/Language/KURE/Utilities.hs deleted file mode 100644 --- a/Language/KURE/Utilities.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE TupleSections #-} - --- | --- Module: Language.KURE.Utilities --- Copyright: (c) 2012 The University of Kansas --- License: BSD3 --- --- Maintainer: Neil Sculthorpe --- 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 - -------------------------------------------------------------------------------- diff --git a/Language/KURE/Walker.hs b/Language/KURE/Walker.hs --- a/Language/KURE/Walker.hs +++ b/Language/KURE/Walker.hs @@ -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 @@ -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 #-} ------------------------------------------------------------------------------- diff --git a/examples/Expr/Examples.hs b/examples/Expr/Examples.hs --- a/examples/Expr/Examples.hs +++ b/examples/Expr/Examples.hs @@ -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 ] ----------------------------------------------------------------- diff --git a/examples/Expr/Kure.hs b/examples/Expr/Kure.hs --- a/examples/Expr/Kure.hs +++ b/examples/Expr/Kure.hs @@ -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 (<*>) #-} --------------------------------------------------------------------------- diff --git a/examples/Fib/Examples.hs b/examples/Fib/Examples.hs --- a/examples/Fib/Examples.hs +++ b/examples/Fib/Examples.hs @@ -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)) ----------------------------------------------------------------------- diff --git a/examples/Fib/Kure.hs b/examples/Fib/Kure.hs --- a/examples/Fib/Kure.hs +++ b/examples/Fib/Kure.hs @@ -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 (<*>) #-} -------------------------------------------------------------------------------------- diff --git a/examples/Lam/Examples.hs b/examples/Lam/Examples.hs --- a/examples/Lam/Examples.hs +++ b/examples/Lam/Examples.hs @@ -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 diff --git a/examples/Lam/Kure.hs b/examples/Lam/Kure.hs --- a/examples/Lam/Kure.hs +++ b/examples/Lam/Kure.hs @@ -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 (<*>) #-} ------------------------------------------------------------------------------- diff --git a/kure.cabal b/kure.cabal --- a/kure.cabal +++ b/kure.cabal @@ -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 -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