kure 0.3.1 → 2.18.6
raw patch · 37 files changed
Files
- CHANGELOG.md +9/−0
- LICENSE +1/−2
- Language/KURE.hs +18/−16
- Language/KURE/BiTransform.hs +148/−0
- Language/KURE/Combinators.hs +16/−185
- Language/KURE/Combinators/Arrow.hs +95/−0
- Language/KURE/Combinators/Monad.hs +63/−0
- Language/KURE/Combinators/Transform.hs +336/−0
- Language/KURE/Debug.hs +25/−0
- Language/KURE/ExtendableContext.hs +48/−0
- Language/KURE/Injection.hs +147/−0
- Language/KURE/Lens.hs +126/−0
- Language/KURE/MonadCatch.hs +207/−0
- Language/KURE/Path.hs +156/−0
- Language/KURE/Pathfinder.hs +115/−0
- Language/KURE/Rewrite.hs +0/−46
- Language/KURE/RewriteMonad.hs +0/−165
- Language/KURE/Term.hs +0/−115
- Language/KURE/Transform.hs +252/−0
- Language/KURE/Translate.hs +0/−70
- Language/KURE/Walker.hs +637/−0
- Setup.hs +0/−2
- Setup.lhs +2/−0
- examples/Examples.hs +21/−0
- examples/Expr/AST.hs +26/−0
- examples/Expr/Context.hs +58/−0
- examples/Expr/Examples.hs +187/−0
- examples/Expr/Kure.hs +126/−0
- examples/Fib/AST.hs +18/−0
- examples/Fib/Examples.hs +152/−0
- examples/Fib/Kure.hs +26/−0
- examples/Lam/AST.hs +17/−0
- examples/Lam/Context.hs +48/−0
- examples/Lam/Examples.hs +240/−0
- examples/Lam/Kure.hs +63/−0
- examples/Lam/Monad.hs +57/−0
- kure.cabal +59/−21
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+## 2.18.6+* Maintenance update for GHC and base library changes involving Typeable, SemiGroup and MonadFail++## 2.16.12+* Derive `Typeable` instances++## 2.16.5+* Allowed building with `base-4.8.0.0`+* Removed unneeded `Monoid` constraints on `OneT` instances
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2006-2009 Andy Gill+(c) 2006-2021 The University of Kansas All rights reserved. Redistribution and use in source and binary forms, with or without@@ -22,4 +22,3 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-
Language/KURE.hs view
@@ -1,26 +1,28 @@ -- | -- Module: Language.KURE--- Copyright: (c) 2006-2008 Andy Gill+-- Copyright: (c) 2012--2021 The University of Kansas -- License: BSD3 ----- Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta -- Portability: ghc -- -- This is the main import module for KURE, which exports all the major components.---+-- The basic transformation functionality can be found in "Language.KURE.Transform",+-- and the traversal functionality can be found in "Language.KURE.Walker". ----module Language.KURE - ( module Language.KURE.RewriteMonad- , module Language.KURE.Translate- , module Language.KURE.Rewrite- , module Language.KURE.Combinators- , module Language.KURE.Term- ) where+module Language.KURE+ ( module Language.KURE.Transform+ , module Language.KURE.Walker+ , module Language.KURE.Combinators+ , module Language.KURE.MonadCatch+ , module Language.KURE.Injection+ , module Language.KURE.Path+) where -import Language.KURE.RewriteMonad-import Language.KURE.Translate-import Language.KURE.Rewrite import Language.KURE.Combinators-import Language.KURE.Term+import Language.KURE.MonadCatch+import Language.KURE.Transform+import Language.KURE.Injection+import Language.KURE.Path+import Language.KURE.Walker
+ Language/KURE/BiTransform.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs #-}+-- |+-- Module: Language.KURE.BiTransform+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- A bi-directional transformation is a transformation that can be applied in either direction.++module Language.KURE.BiTransform+ ( -- * Bi-directional Transformations+ BiTransform, BiTranslate+ , BiRewrite+ , bidirectional+ , forwardT+ , backwardT+ , whicheverR+ , invertBiT+ , beforeBiR+ , afterBiR+ -- * Bi-directional Injections+ , extractBiT+ , promoteBiT+ , extractBiR+ , promoteBiR+ , extractWithFailMsgBiT+ , promoteWithFailMsgBiT+ , extractWithFailMsgBiR+ , promoteWithFailMsgBiR+) where++import Prelude hiding (id, (.))++import Control.Category++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Language.KURE.MonadCatch+import Language.KURE.Transform+import Language.KURE.Injection++------------------------------------------------------------------------------------------++-- | An undirected 'Transform'.+data BiTransform c m a b = BiTransform {forwardT :: Transform c m a b, -- ^ Extract the forward 'Transform' from a 'BiTransform'.+ backwardT :: Transform c m b a -- ^ Extract the backward 'Transform' from a 'BiTransform'.+ }++-- | A deprecated synonym for 'BiTranslate'.+type BiTranslate c m a b = BiTransform c m a b++-- | A 'BiTransform' that shares the same source and target type.+type BiRewrite c m a = BiTransform c m a a++-- | Construct a 'BiTransform' from two opposite 'Transform's.+bidirectional :: Transform c m a b -> Transform c m b a -> BiTransform c m a b+bidirectional = BiTransform+{-# INLINE bidirectional #-}++-- | Try the 'BiRewrite' forwards, then backwards if that fails.+-- Useful when you know which rule you want to apply, but not which direction to apply it in.+whicheverR :: MonadCatch m => BiRewrite c m a -> Rewrite c m a+whicheverR r = forwardT r <+ backwardT r+{-# INLINE whicheverR #-}++-- | Invert the forwards and backwards directions of a 'BiTransform'.+invertBiT :: BiTransform c m a b -> BiTransform c m b a+invertBiT (BiTransform t1 t2) = BiTransform t2 t1+{-# INLINE invertBiT #-}++instance Monad m => Category (BiTransform c m) where+ id :: BiTransform c m a a+ id = bidirectional id id+ {-# INLINE id #-}++ (.) :: BiTransform c m b d -> BiTransform c m a b -> BiTransform c m a d+ (BiTransform f1 b1) . (BiTransform f2 b2) = BiTransform (f1 . f2) (b2 . b1)+ {-# INLINE (.) #-}++------------------------------------------------------------------------------------------++-- | Perform the argument transformation before /either/ direction of the bidirectional rewrite.+beforeBiR :: Monad m => Transform c m a b -> (b -> BiRewrite c m a) -> BiRewrite c m a+beforeBiR t f = bidirectional (t >>= (forwardT . f)) (t >>= (backwardT . f))+{-# INLINE beforeBiR #-}++-- | Apply the argument rewrite to the result of /either/ direction of the bidirectional rewrite.+afterBiR :: Monad m => BiRewrite c m a -> Rewrite c m a -> BiRewrite c m a+afterBiR b rr = bidirectional (forwardT b >>> rr) (backwardT b >>> rr)+{-# INLINE afterBiR #-}++------------------------------------------------------------------------------------------++-- | As 'extractBiT', but takes a custom error message to use if extraction fails.+extractWithFailMsgBiT :: (MonadFail m, Injection a u, Injection b u) => String -> BiTransform c m u u -> BiTransform c m a b+extractWithFailMsgBiT msg (BiTransform t1 t2) = BiTransform (extractT t1 >>> projectWithFailMsgT msg)+ (extractT t2 >>> projectWithFailMsgT msg)+{-# INLINE extractWithFailMsgBiT #-}++-- | Convert a bidirectional transformation over an injected value into a bidirectional transformation over non-injected values,+-- (failing if an injected value cannot be projected).+extractBiT :: (MonadFail m, Injection a u, Injection b u) => BiTransform c m u u -> BiTransform c m a b+extractBiT = extractWithFailMsgBiT "extractBiT failed"+{-# INLINE extractBiT #-}++-- | As 'promoteBiT', but takes a custom error message to use if promotion fails.+promoteWithFailMsgBiT :: (MonadFail m, Injection a u, Injection b u) => String -> BiTransform c m a b -> BiTransform c m u u+promoteWithFailMsgBiT msg (BiTransform t1 t2) = BiTransform (projectWithFailMsgT msg >>> t1 >>> injectT)+ (projectWithFailMsgT msg >>> t2 >>> injectT)+{-# INLINE promoteWithFailMsgBiT #-}++-- | Promote a bidirectional transformation from value to value into a transformation over an injection of those values,+-- (failing if an injected value cannot be projected).+promoteBiT :: (MonadFail m, Injection a u, Injection b u) => BiTransform c m a b -> BiTransform c m u u+promoteBiT = promoteWithFailMsgBiT "promoteBiT failed"+{-# INLINE promoteBiT #-}++-- | As 'extractBiR', but takes a custom error message to use if extraction fails.+extractWithFailMsgBiR :: (MonadFail m, Injection a u) => String -> BiRewrite c m u -> BiRewrite c m a+extractWithFailMsgBiR msg (BiTransform r1 r2) = BiTransform (extractWithFailMsgR msg r1)+ (extractWithFailMsgR msg r2)+{-# INLINE extractWithFailMsgBiR #-}++-- | Convert a bidirectional rewrite over an injected value into a bidirectional rewrite over a projection of that value,+-- (failing if an injected value cannot be projected).+extractBiR :: (MonadFail m, Injection a u) => BiRewrite c m u -> BiRewrite c m a+extractBiR = extractWithFailMsgBiR "extractBiR failed"+{-# INLINE extractBiR #-}++-- | As 'promoteBiR', but takes a custom error message to use if promotion fails.+promoteWithFailMsgBiR :: (MonadFail m, Injection a u) => String -> BiRewrite c m a -> BiRewrite c m u+promoteWithFailMsgBiR msg (BiTransform r1 r2) = BiTransform (promoteWithFailMsgR msg r1)+ (promoteWithFailMsgR msg r2)+{-# INLINE promoteWithFailMsgBiR #-}++-- | Promote a bidirectional rewrite over a value into a bidirectional rewrite over an injection of that value,+-- (failing if an injected value cannot be projected).+promoteBiR :: (MonadFail m, Injection a u) => BiRewrite c m a -> BiRewrite c m u+promoteBiR = promoteWithFailMsgBiR "promoteBiR failed"+{-# INLINE promoteBiR #-}++------------------------------------------------------------------------------------------
Language/KURE/Combinators.hs view
@@ -1,193 +1,24 @@ -- |--- Module: Language.KURE.Combinators --- Copyright: (c) 2006-2008 Andy Gill+-- Module: Language.KURE.Combinators+-- Copyright: (c) 2012--2021 The University of Kansas -- License: BSD3 ----- Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta -- Portability: ghc ----- This module contains various combinators that use 'Translate' and 'Rewrite'. The convension is that--- 'Translate' based combinators end with @T@, and 'Rewrite' based combinators end with @R@. Of course,--- because 'Rewrite' is a type synomim of 'Translate', the 'Rewrite' functions also operate with on 'Translate',--- and the 'Translate' functions operate with 'Rewrite'. --module Language.KURE.Combinators - ( -- * The 'Translate' combinators- (<+)- , (>->)- , failT- , readerT- , readEnvT- , mapEnvT- , writeEnvT- , pureT- , constT- , concatT- , -- * The 'Rewrite' combinators- (.+)- , (!->)- , tryR- , changedR- , repeatR- , acceptR- , idR- , failR- , -- * The Prelude combinators- tuple2R- , listR- , maybeR- , tuple2U- , listU- , maybeU- , -- * Generic failure, over both 'Monad's and 'Translate's.- (?)- , Failable(..)- ) where - -import Language.KURE.RewriteMonad -import Language.KURE.Translate -import Language.KURE.Rewrite -import Data.Monoid-import Control.Monad--infixl 3 <+, >->, .+, !->-infixr 3 ?---- Note: We use < for catching fail, . for catching id.------------------------------------------------------------------------------------- The Translate combinators.---- | like a catch, '<+' does the first translate , and if it fails, then does the second translate. -(<+) :: (Monoid dec, Monad m) => Translate m dec a b -> Translate m dec a b -> Translate m dec a b-(<+) rr1 rr2 = transparently $ translate $ \ e -> apply rr1 e `catchM` (\ _ -> apply rr2 e)---- | like a @;@ If the first translate succeeds, then do to the second translate after the first translate.-(>->) :: (Monoid dec, Monad m) => Translate m dec a b -> Translate m dec b c -> Translate m dec a c-(>->) rr1 rr2 = transparently $ translate $ \ e -> chainM (apply rr1 e) ( \ _i e2 -> apply rr2 e2)---- | failing translation.-failT :: (Monad m, Monoid dec) => String -> Translate m dec a b-failT msg = translate $ \ _ -> failM msg----- | look at the argument for the translation before choosing which translation to perform. -readerT :: (Monoid dec, Monad m) => (a -> Translate m dec a b) -> Translate m dec a b-readerT fn = transparently $ translate $ \ expA -> apply (fn expA) expA---- | look at the @dec@ before choosing which translation to do.-readEnvT :: (Monad m, Monoid dec) => (dec -> Translate m dec a b) -> Translate m dec a b-readEnvT f = transparently $ translate $ \ e -> - do dec <- readEnvM - apply (f dec) e---- | add to the context 'dec', which is propogated using a writer monad.-writeEnvT :: (Monad m, Monoid dec) => dec -> Rewrite m dec a-writeEnvT dec = translate $ \ e -> do writeEnvM dec ; return e---- | change the @dec@'s for a scoped translation.-mapEnvT :: (Monoid dec,Monad m) => (dec -> dec) -> Translate m dec a r -> Translate m dec a r-mapEnvT f_env rr = transparently $ translate $ \ e -> mapEnvM f_env (apply rr e)---- | 'pureT' promotes a function into an unfailable, non-identity 'Translate'.-pureT :: (Monad m,Monoid dec) => (a -> b) -> Translate m dec a b-pureT f = translate $ \ a -> return (f a)---- | 'constT' always translates into an unfailable 'Translate' that returns the first argument.-constT :: (Monad m,Monoid dec) => b -> Translate m dec a b-constT = pureT . const---- | 'concatT' composes a list of 'Translate' into a single 'Translate' which 'mconcat's its result.-concatT :: (Monad m,Monoid dec,Monoid r) => [Translate m dec a r] -> Translate m dec a r-concatT ts = translate $ \ e -> do- rs <- sequence [ apply t e | t <- ts ]- return (mconcat rs)------------------------------------------------------------------------------------ The 'Rewrite' combinators.---- | if the first rewrite is an identity, then do the second rewrite.-(.+) :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a -> Rewrite m dec a-(.+) a b = a `countTrans` (\ i -> if i == 0 then b else idR)---- | if the first rewrite was /not/ an identity, then also do the second rewrite.-(!->) :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a -> Rewrite m dec a -(!->) a b = a `countTrans` (\ i -> if i == 0 then idR else b)---- | catch a failing 'Rewrite', making it into an identity.-tryR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a-tryR s = s <+ idR---- | if this is an identity rewrite, make it fail. To succeed, something must have changed.-changedR :: (Monoid dec,Monad m) => Rewrite m dec a -> Rewrite m dec a-changedR rr = rr .+ failR "unchanged"---- | repeat a rewrite until it fails, then return the result before the failure.-repeatR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a-repeatR s = tryR (s >-> repeatR s) ---- | look at the argument to a rewrite, and choose to be either a failure of trivial success.-acceptR :: (Monoid dec, Monad m) => (a -> Bool) -> Rewrite m dec a-acceptR fn = transparently $ translate $ \ expA ->- if fn expA - then return expA- else fail "accept failed"----- | identity rewrite.-idR :: (Monad m, Monoid dec) => Rewrite m dec exp-idR = transparently $ rewrite $ \ e -> return e---- | failing rewrite.-failR :: (Monad m, Monoid dec) => String -> Rewrite m dec a-failR = failT------------------------------------------------------------------------------------- Prelude structures--tuple2R :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec b -> Rewrite m dec (a,b)-tuple2R rra rrb = transparently $ rewrite $ \ (a,b) -> liftM2 (,) (apply rra a) (apply rrb b)--listR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec [a]-listR rr = transparently $ rewrite $ mapM (apply rr)--maybeR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec (Maybe a)-maybeR rr = transparently $ rewrite $ \ e -> case e of- Just e' -> liftM Just (apply rr e')- Nothing -> return $ Nothing--tuple2U :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec b r -> Translate m dec (a,b) r-tuple2U rra rrb = translate $ \ (a,b) -> liftM2 mappend (apply rra a) (apply rrb b)--listU :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec [a] r-listU rr = translate $ liftM mconcat . mapM (apply rr)--maybeU :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec (Maybe a) r-maybeU rr = translate $ \ e -> case e of- Just e' -> apply rr e'- Nothing -> return $ mempty------------------------------------------------------------------------------------- | Failable structure.-class Failable f where- failure :: String -> f a--instance (Monad m, Monoid dec) => Failable (Translate m dec a) where - failure msg = failT msg--instance (Monad m, Monoid dec) => Failable (RewriteM m dec) where - failure msg = fail msg- --- | Guarded translate or monadic action.-(?) :: (Failable f) => Bool -> f a -> f a-(?) False _rr = failure "(False ?)"-(?) True rr = rr+-- This module provides various monadic and arrow combinators that are useful when+-- working with 'Language.KURE.Transform.Transform's and 'Language.KURE.Transform.Rewrite's. +module Language.KURE.Combinators+ (+ module Language.KURE.Combinators.Transform+ , module Language.KURE.Combinators.Monad+ , module Language.KURE.Combinators.Arrow+) where ------------------------------------------------------------------------------------ internal to this module.-countTrans :: (Monoid dec, Monad m) => Rewrite m dec a -> (Int -> Rewrite m dec a) -> Rewrite m dec a-countTrans rr fn = transparently $ translate $ \ e ->- chainM (apply rr e)- (\ i e' -> apply (fn i) e')+import Language.KURE.Combinators.Monad+import Language.KURE.Combinators.Arrow+import Language.KURE.Combinators.Transform +------------------------------------------------------------------------------------------
+ Language/KURE/Combinators/Arrow.hs view
@@ -0,0 +1,95 @@+-- |+-- Module: Language.KURE.Combinators.Arrow+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- 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.+ -- <http://conal.net/blog/posts/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.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 arrows to the same input, combining their results in a monoid.+parallelise :: (Foldable f, Arrow bi, Monoid b) => f (bi a b) -> bi a b+parallelise = foldr (\ f g -> (f &&& g) >>^ uncurry mappend) (constant mempty)+{-# INLINE parallelise #-}++-------------------------------------------------------------------------------
+ Language/KURE/Combinators/Monad.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: Language.KURE.Combinators.Monad+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides conditional monadic combinators.++module Language.KURE.Combinators.Monad+ ( -- * Monadic Conditionals+ guardMsg+ , guardM+ , guardMsgM+ , ifM+ , whenM+ , unlessM+) where++import Control.Monad (unless)++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail(MonadFail)+#endif++------------------------------------------------------------------------------------------++-- | Similar to 'guard', but invokes 'fail' rather than 'mzero'.+guardMsg :: MonadFail m => Bool -> String -> m ()+guardMsg b msg = unless b (fail msg)+{-# INLINE guardMsg #-}++-- | As 'guardMsg', but with a default error message.+guardM :: MonadFail m => Bool -> m ()+guardM b = guardMsg b "guardM failed"+{-# INLINE guardM #-}++-- | As 'guardMsg', but with an @m Bool@ as argument.+guardMsgM :: MonadFail m => m Bool -> String -> m ()+guardMsgM mb msg = do b <- mb+ guardMsg b msg+{-# INLINE guardMsgM #-}++-- | 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 :: MonadFail 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 :: MonadFail m => m Bool -> m a -> m a+unlessM mb ma = ifM mb (fail "unlessM: condition True") ma+{-# INLINE unlessM #-}++------------------------------------------------------------------------------------------
+ Language/KURE/Combinators/Transform.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs #-}+-- |+-- Module: Language.KURE.Combinators.Transform+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides a variety of combinators over 'Transform' and 'Rewrite'.++module Language.KURE.Combinators.Transform+ ( -- * Transformation Combinators+ idR+ , successT+ , contextT+ , exposeT+ , liftContext+ , readerT+ , resultT+ , catchesT+ , mapT+ , joinT+ , guardT+ -- * Rewrite Combinators+ , tryR+ , andR+ , orR+ , (>+>)+ , repeatR+ , acceptR+ , acceptWithFailMsgR+ , accepterR+ , changedR+ , changedByR+ , sideEffectR+ -- * Monad Transformers+ -- ** anyR Support+ -- $AnyR_doc+ , AnyR+ , wrapAnyR+ , unwrapAnyR+ -- ** oneR Support+ -- $OneR_doc+ , OneR+ , wrapOneR+ , unwrapOneR+) where++import Prelude hiding (id, map, foldr, mapM)++import Control.Category ((>>>),id)+import Control.Monad (liftM,ap)++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail+#endif++import Data.Foldable ()+import Data.Traversable++import Language.KURE.Combinators.Arrow+import Language.KURE.Combinators.Monad+import Language.KURE.MonadCatch+import Language.KURE.Transform++------------------------------------------------------------------------------------------++-- | The identity rewrite.+idR :: Monad m => Rewrite c m a+idR = id+{-# INLINE idR #-}++-- | An always successful transformation.+successT :: Monad m => Transform c m a ()+successT = return ()+{-# INLINE successT #-}++-- | Extract the current context.+contextT :: Monad m => Transform c m a c+contextT = transform (\ c _ -> return c)+{-# INLINE contextT #-}++-- | Expose the current context and value.+exposeT :: Monad m => Transform c m a (c,a)+exposeT = transform (curry return)+{-# INLINE exposeT #-}++-- | Lift a transformation to operate on a derived context.+liftContext :: (c -> c') -> Transform c' m a b -> Transform c m a b+liftContext f t = transform (applyT t . f)+{-# INLINE liftContext #-}++-- | Map a transformation over a list.+mapT :: (Traversable t, Monad m) => Transform c m a b -> Transform c m (t a) (t b)+mapT t = transform (mapM . applyT t)+{-# INLINE mapT #-}++-- | An identity rewrite with side-effects.+sideEffectR :: Monad m => (c -> a -> m ()) -> Rewrite c m a+sideEffectR f = transform f >> id+{-# INLINE sideEffectR #-}++-- | Look at the argument to the transformation before choosing which 'Transform' to use.+readerT :: (a -> Transform c m a b) -> Transform c m a b+readerT f = transform (\ c a -> applyT (f a) c a)+{-# INLINE readerT #-}++-- | Convert the monadic result of a transformation into a result in another monad.+resultT :: (m b -> n d) -> Transform c m a b -> Transform c n a d+resultT f t = transform (\ c -> f . applyT t c)+{-# INLINE resultT #-}++-- | Perform a collection of rewrites in sequence, requiring all to succeed.+andR :: (Foldable f, Monad m) => f (Rewrite c m a) -> Rewrite c m a+andR = serialise+{-# INLINE andR #-}++-- | Perform two rewrites in sequence, succeeding if one or both succeed.+(>+>) :: MonadCatch m => Rewrite c m a -> Rewrite c m a -> Rewrite c m a+r1 >+> r2 = unwrapAnyR (wrapAnyR r1 >>> wrapAnyR r2)+{-# INLINE (>+>) #-}++-- | Perform a collection of rewrites in sequence, succeeding if any succeed.+orR :: (Functor f, Foldable f, MonadCatch m) => f (Rewrite c m a) -> Rewrite c m a+orR = unwrapAnyR . andR . fmap wrapAnyR+{-# INLINE orR #-}++-- | As 'acceptR', but takes a custom failure message.+acceptWithFailMsgR :: MonadFail m => (a -> Bool) -> String -> Rewrite c m a+acceptWithFailMsgR p msg = readerT $ \ a -> if p a then id else fail msg+{-# INLINE acceptWithFailMsgR #-}++-- | Look at the argument to a rewrite, and choose to be either 'idR' or a failure.+acceptR :: MonadFail m => (a -> Bool) -> Rewrite c m a+acceptR p = acceptWithFailMsgR p "acceptR: predicate failed"+{-# INLINE acceptR #-}++-- | A generalisation of 'acceptR' where the predicate is a 'Transform'.+accepterR :: MonadFail m => Transform c m a Bool -> Rewrite c m a+accepterR t = ifM t idR (fail "accepterR: predicate failed")+{-# INLINE accepterR #-}++-- | Catch a failing rewrite, making it into an identity.+tryR :: MonadCatch m => Rewrite c m a -> Rewrite c m a+tryR r = r <+ id+{-# INLINE tryR #-}++-- | Makes a rewrite fail if the result value and the argument value satisfy the equality predicate.+-- This is a generalisation of 'changedR'.+-- @changedR = changedByR ('==')@+changedByR :: MonadCatch m => (a -> a -> Bool) -> Rewrite c m a -> Rewrite c m a+changedByR p r = readerT (\ a -> r >>> acceptWithFailMsgR (not . p a) "changedByR: value is unchanged")+{-# INLINE changedByR #-}++-- | Makes an rewrite fail if the result value equals the argument value.+changedR :: (MonadCatch m, Eq a) => Rewrite c m a -> Rewrite c m a+changedR = changedByR (==)+{-# INLINE changedR #-}++-- | Repeat a rewrite until it fails, then return the result before the failure.+-- Requires at least the first attempt to succeed.+repeatR :: MonadCatch m => Rewrite c m a -> Rewrite c m a+repeatR r = let go = r >>> tryR go+ in go+{-# INLINE repeatR #-}++-- | Attempt each transformation until one succeeds, then return that result and discard the rest of the transformations.+catchesT :: MonadCatch m => [Transform c m a b] -> Transform c m a b+catchesT = catchesM+{-# INLINE catchesT #-}+{-# DEPRECATED catchesT "Please use 'catchesM' instead." #-}+++-- | An identity transformation that resembles a monadic 'Control.Monad.join'.+joinT :: Transform c m (m a) a+joinT = contextfreeT id+{-# INLINE joinT #-}++-- | Fail if the Boolean is False, succeed if the Boolean is True.+guardT :: MonadFail m => Transform c m Bool ()+guardT = contextfreeT guardM+{-# INLINE guardT #-}++-------------------------------------------------------------------------------++data PBool a = PBool !Bool a++instance Functor PBool where+ fmap :: (a -> b) -> PBool a -> PBool b+ fmap f (PBool b a) = PBool b (f a)++checkSuccessPBool :: MonadFail m => String -> m (PBool a) -> m a+checkSuccessPBool msg m = do PBool b a <- m+ if b+ then return a+ else fail msg+{-# INLINE checkSuccessPBool #-}++-------------------------------------------------------------------------------++-- $AnyR_doc+-- These are useful when defining congruence combinators that succeed if /any/ child rewrite succeeds.+-- See the \"Expr\" example, or the HERMIT package.++-- | The 'AnyR' transformer, in combination with 'wrapAnyR' and 'unwrapAnyR',+-- causes a sequence of rewrites to succeed if at least one succeeds, converting failures to+-- identity rewrites.+newtype AnyR m a = AnyR (m (PBool a))++unAnyR :: AnyR m a -> m (PBool a)+unAnyR (AnyR mba) = mba+{-# INLINE unAnyR #-}++instance Monad m => Functor (AnyR m) where+ fmap :: (a -> b) -> AnyR m a -> AnyR m b+ fmap = liftM+ {-# INLINE fmap #-}++instance Monad m => Applicative (AnyR m) where+ pure :: a -> AnyR m a+ pure = return+ {-# INLINE pure #-}++ (<*>) :: AnyR m (a -> b) -> AnyR m a -> AnyR m b+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad m => Monad (AnyR m) where+ return :: a -> AnyR m a+ return = AnyR . return . PBool False+ {-# INLINE return #-}++ (>>=) :: 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 (>>=) #-}++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> AnyR m a+ fail = AnyR . fail+ {-# INLINE fail #-}+#endif++instance MonadFail m => MonadFail (AnyR m) where+ fail :: String -> AnyR m a+ fail = AnyR . fail+ {-# INLINE fail #-}++instance MonadCatch m => MonadCatch (AnyR m) where+ catchM :: AnyR m a -> (String -> AnyR m a) -> AnyR m a+ catchM ma f = AnyR (unAnyR ma `catchM` (unAnyR . f))+ {-# INLINE catchM #-}++-- | Wrap a 'Rewrite' using the 'AnyR' monad transformer.+wrapAnyR :: MonadCatch m => Rewrite c m a -> Rewrite c (AnyR m) a+wrapAnyR r = rewrite $ \ c a -> AnyR $ (PBool True `liftM` applyR r c a) <+ return (PBool False a)+{-# INLINE wrapAnyR #-}++-- | Unwrap a 'Rewrite' from the 'AnyR' monad transformer.+unwrapAnyR :: MonadFail m => Rewrite c (AnyR m) a -> Rewrite c m a+unwrapAnyR = resultT (checkSuccessPBool "anyR failed" . unAnyR)+{-# INLINE unwrapAnyR #-}++-------------------------------------------------------------------------------++-- $OneR_doc+-- These are useful when defining congruence combinators that succeed if one child rewrite succeeds+-- (and the remainder are then discarded).+-- See the \"Expr\" example, or the HERMIT package.++-- | The 'OneR' transformer, in combination with 'wrapOneR' and 'unwrapOneR',+-- causes a sequence of rewrites to only apply the first success, converting the remainder (and failures) to identity rewrites.+newtype OneR m a = OneR (Bool -> m (PBool a))++unOneR :: OneR m a -> Bool -> m (PBool a)+unOneR (OneR mba) = mba+{-# INLINE unOneR #-}++instance Monad m => Functor (OneR m) where+ fmap :: (a -> b) -> OneR m a -> OneR m b+ fmap = liftM+ {-# INLINE fmap #-}++instance Monad m => Applicative (OneR m) where+ pure :: a -> OneR m a+ pure = return+ {-# INLINE pure #-}++ (<*>) :: OneR m (a -> b) -> OneR m a -> OneR m b+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad m => Monad (OneR m) where+ return :: a -> OneR m a+ return a = OneR (\ b -> return (PBool b a))+ {-# INLINE return #-}++ (>>=) :: 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 (>>=) #-}++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> OneR m a+ fail msg = OneR (\ _ -> fail msg)+ {-# INLINE fail #-}+#endif++instance MonadFail m => MonadFail (OneR m) where+ fail :: String -> OneR m a+ fail msg = OneR (\ _ -> fail msg)+ {-# INLINE fail #-}++instance MonadCatch m => MonadCatch (OneR m) where+ catchM :: OneR m a -> (String -> OneR m a) -> OneR m a+ catchM (OneR g) f = OneR (\ b -> g b `catchM` (($ b) . unOneR . f))+ {-# INLINE catchM #-}++-- | Wrap a 'Rewrite' using the 'OneR' monad transformer.+wrapOneR :: MonadCatch m => Rewrite c m g -> Rewrite c (OneR m) g+wrapOneR r = rewrite $ \ c a -> OneR $ \ b -> if b+ then return (PBool True a)+ else (PBool True `liftM` applyR r c a) <+ return (PBool False a)+{-# INLINE wrapOneR #-}++-- | Unwrap a 'Rewrite' from the 'OneR' monad transformer.+unwrapOneR :: MonadFail m => Rewrite c (OneR m) a -> Rewrite c m a+unwrapOneR = resultT (checkSuccessPBool "oneR failed" . ($ False) . unOneR)+{-# INLINE unwrapOneR #-}++-------------------------------------------------------------------------------
+ Language/KURE/Debug.hs view
@@ -0,0 +1,25 @@+-- |+-- Module: Language.KURE.Debug+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides (unsafe) debugging/tracing combinators.+--+module Language.KURE.Debug (+ debugR+) where++import Control.Monad.Fail+import Debug.Trace++import Language.KURE.Combinators.Transform+import Language.KURE.Transform+++-- | Trace output of the value being rewritten; use for debugging only.+debugR :: (MonadFail m, Show a) => Int -> String -> Rewrite c m a+debugR n msg = acceptR (\ a -> trace (msg ++ " : " ++ take n (show a)) True)
+ Language/KURE/ExtendableContext.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module: Language.KURE.ExtendableContext+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides a utility data type for extending an existing context with extra information.+-- The idea is that, after defining class instances for any user-specific contextual operations, it can be used for any ad-hoc context extensions.+-- See the treatment of 'ExtendPath' as an example.++module Language.KURE.ExtendableContext+ (+ -- * Extending Contexts+ ExtendContext+ , extendContext+ , baseContext+ , extraContext+) where++import Language.KURE.Path++------------------------------------------------------------------------------------------------++-- | A context transformer, for augmenting a context with additional information.+data ExtendContext c e = ExtendContext+ { -- | Retrieve the base context (without the extra information).+ baseContext :: c+ -- | Retrieve the extra contextual information.+ , extraContext :: e+ }++-- | Extend a context with some additional information.+extendContext :: e -> c -> ExtendContext c e+extendContext e c = ExtendContext c e++-- | Both components of the context are updated with the crumb.+instance (ExtendPath c crumb, ExtendPath e crumb) => ExtendPath (ExtendContext c e) crumb where+ (@@) :: ExtendContext c e -> crumb -> ExtendContext c e+ (ExtendContext c e) @@ cr = ExtendContext (c @@ cr) (e @@ cr)++------------------------------------------------------------------------------------------------
+ Language/KURE/Injection.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- Module: Language.KURE.Injection+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides a type class for injective functions (and their projections),+-- and some useful interactions with 'Transform'.+--+module Language.KURE.Injection+ ( -- * Injection Class+ Injection(..)+ -- * Monad Injections+ , injectM+ , projectM+ , projectWithFailMsgM+ -- * Transformation Injections+ , injectT+ , projectT+ , extractT+ , promoteT+ , projectWithFailMsgT+ , promoteWithFailMsgT+ -- * Rewrite Injections+ , extractR+ , promoteR+ , extractWithFailMsgR+ , promoteWithFailMsgR+) where++import Control.Arrow++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Language.KURE.Transform++-------------------------------------------------------------------------------++-- | A class of injective functions from @a@ to @b@, and their projections.+-- The following law is expected to hold:+--+-- > project (inject a) == Just a++class Injection a u where+ inject :: a -> u+ project :: u -> Maybe a++-- | There is an identity injection for all types.+instance Injection a a where+ inject :: a -> a+ inject = id+ {-# INLINE inject #-}++ project :: a -> Maybe a+ project = Just+ {-# INLINE project #-}++instance Injection a (Maybe a) where+ inject :: a -> Maybe a+ inject = Just+ {-# INLINE inject #-}++ project :: Maybe a -> Maybe a+ project = id+ {-# INLINE project #-}++-------------------------------------------------------------------------------++-- | Injects a value and lifts it into a 'Monad'.+injectM :: (Monad m, Injection a u) => a -> m u+injectM = return . inject+{-# INLINE injectM #-}++-- | As 'projectM', but takes a custom error message to use if projection fails.+projectWithFailMsgM :: (MonadFail m, Injection a u) => String -> u -> m a+projectWithFailMsgM msg = maybe (fail msg) return . project+{-# INLINE projectWithFailMsgM #-}++-- | Projects a value and lifts it into a 'Monad', with the possibility of failure.+projectM :: (MonadFail m, Injection a u) => u -> m a+projectM = projectWithFailMsgM "projectM failed"+{-# INLINE projectM #-}++-------------------------------------------------------------------------------++-- | Lifted 'inject'.+injectT :: (Monad m, Injection a u) => Transform c m a u+injectT = arr inject+{-# INLINE injectT #-}++projectWithFailMsgT :: (MonadFail m, Injection a u) => String -> Transform c m u a+projectWithFailMsgT = contextfreeT . projectWithFailMsgM+{-# INLINE projectWithFailMsgT #-}++-- | Lifted 'project', the transformation fails if the projection fails.+projectT :: (MonadFail m, Injection a u) => Transform c m u a+projectT = projectWithFailMsgT "projectT failed"+{-# INLINE projectT #-}++-- | Convert a transformation over an injected value into a transformation over a non-injected value.+extractT :: (Monad m, Injection a u) => Transform c m u b -> Transform c m a b+extractT t = injectT >>> t+{-# INLINE extractT #-}++-- | As 'promoteT', but takes a custom error message to use if promotion fails.+promoteWithFailMsgT :: (MonadFail m, Injection a u) => String -> Transform c m a b -> Transform c m u b+promoteWithFailMsgT msg t = projectWithFailMsgT msg >>> t+{-# INLINE promoteWithFailMsgT #-}++-- | Promote a transformation over a value into a transformation over an injection of that value,+-- (failing if that injected value cannot be projected).+promoteT :: (MonadFail m, Injection a u) => Transform c m a b -> Transform c m u b+promoteT = promoteWithFailMsgT "promoteT failed"+{-# INLINE promoteT #-}++-- | As 'extractR', but takes a custom error message to use if extraction fails.+extractWithFailMsgR :: (MonadFail m, Injection a u) => String -> Rewrite c m u -> 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 projection of that value,+-- (failing if that injected value cannot be projected).+extractR :: (MonadFail m, Injection a u) => Rewrite c m u -> Rewrite c m a+extractR = extractWithFailMsgR "extractR failed"+{-# INLINE extractR #-}++-- | As 'promoteR', but takes a custom error message to use if promotion fails.+promoteWithFailMsgR :: (MonadFail m, Injection a u) => String -> Rewrite c m a -> Rewrite c m u+promoteWithFailMsgR msg r = projectWithFailMsgT msg >>> r >>> injectT+{-# INLINE promoteWithFailMsgR #-}++-- | Promote a rewrite over a value into a rewrite over an injection of that value,+-- (failing if that injected value cannot be projected).+promoteR :: (MonadFail m, Injection a u) => Rewrite c m a -> Rewrite c m u+promoteR = promoteWithFailMsgR "promoteR failed"+{-# INLINE promoteR #-}++-------------------------------------------------------------------------------
+ Language/KURE/Lens.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs #-}+-- |+-- Module: Language.KURE.Lens+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- 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++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Control.Category+import Control.Arrow++import Language.KURE.MonadCatch+import Language.KURE.Transform+import Language.KURE.BiTransform+import Language.KURE.Injection+import Language.KURE.Combinators.Transform++------------------------------------------------------------------------------------------++-- | A 'Lens' is a way to focus on a sub-structure of type @b@ from a structure of type @a@.+newtype Lens c m a b = Lens { -- | Convert a 'Lens' into a 'Transform' that produces a sub-structure (and its context) and an unfocussing function.+ lensT :: Transform c m a ((c,b), b -> m a)}++-- | The primitive way of building a 'Lens'.+-- If the unfocussing function is applied to the value focussed on then it should succeed,+-- and produce the same value as the original argument (of type @a@).+lens :: Transform c m a ((c,b), b -> m a) -> Lens c m a b+lens = Lens+{-# INLINE lens #-}++-- | Apply a rewrite at a point specified by a 'Lens'.+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 (applyR r c b >>= k)+{-# INLINE focusR #-}++-- | Apply a transformation at a point specified by a 'Lens'.+focusT :: Monad m => Lens c m a b -> Transform c m b d -> Transform c m a d+focusT l t = do ((c,b),_) <- lensT l+ constT (applyT t c b)+{-# INLINE focusT #-}++-- | Check if the focusing succeeds, and additionally whether unfocussing from an unchanged value would succeed.+testLensT :: MonadCatch m => Lens c m a b -> Transform c m a Bool+testLensT l = testM (focusR l id)+{-# INLINE testLensT #-}++instance Monad m => Category (Lens c m) where++ id :: Lens c m a a+ id = lens $ transform $ \ c a -> return ((c,a), return)+ {-# INLINE id #-}++ (.) :: Lens c m b d -> Lens c m a b -> Lens c m a d+ l2 . l1 = lens $ transform $ \ ca a -> do ((cb,b),kb) <- applyT (lensT l1) ca a+ ((cd,d),kd) <- applyT (lensT l2) cb b+ return ((cd,d),kd >=> kb)+ {-# INLINE (.) #-}++-- | The failing 'Lens'.+failL :: MonadFail 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 'catchL' could cause a succeeding 'Lens' application to fail.+-- But provided 'lens' is used correctly, this should never happen.+catchL :: MonadCatch m => Lens c m a b -> (String -> Lens c m a b) -> Lens c m a b+l1 `catchL` l2 = lens (attemptM (focusR l1 idR) >>= either (lensT . l2) (const (lensT l1)))+{-# INLINE catchL #-}++-- | Construct a 'Lens' from a 'BiTransform'.+bidirectionalL :: Monad m => BiTransform c m a b -> Lens c m a b+bidirectionalL bt = lens $ do c <- contextT+ b <- forwardT bt+ return ((c,b), applyT (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 :: (MonadFail m, Injection a g) => Lens c m a g+injectL = lens $ transform $ \ c a -> return ((c, inject a), projectM)+{-# INLINE injectL #-}++-- | A 'Lens' to the projection of a value.+projectL :: (MonadFail m, Injection a g) => Lens c m g a+projectL = lens $ transform $ \ c -> projectM >=> (\ a -> return ((c,a), injectM))+{-# INLINE projectL #-}++-------------------------------------------------------------------------------
+ Language/KURE/MonadCatch.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs #-}+-- |+-- Module: Language.KURE.MonadCatch+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- 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+ , liftKureM+ -- ** The IO Monad+ , liftAndCatchIO+ -- ** Combinators+ , (<+)+ , catchesM+ , tryM+ , mtryM+ , attemptM+ , testM+ , notM+ , modFailMsg+ , setFailMsg+ , prefixFailMsg+ , withPatFailMsg+) where++import Prelude hiding (foldr)++import Control.Exception (catch, SomeException)++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail+#endif++import Control.Monad (liftM, ap, join)+import Control.Monad.IO.Class++import Data.Foldable+import Data.List (isPrefixOf)++import Language.KURE.Combinators.Monad++infixl 3 <+++------------------------------------------------------------------------------------------++-- | 'Monad's with a catch for 'fail'.+-- The following laws are expected to hold:+--+-- > fail msg `catchM` f == f msg+-- > return a `catchM` f == return a++class MonadFail 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', except that it supports a 'MonadCatch' instance which 'Either' 'String' does not (because its 'fail' method calls 'error')+-- A major advantage of this is that monadic pattern match failures are caught safely.+data KureM a = Failure String | Success a deriving (Eq, Show)++-- | 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 #-}++-- | Lift a 'KureM' computation to any other monad.+liftKureM :: MonadFail m => KureM a -> m a+liftKureM = runKureM return fail+{-# INLINE liftKureM #-}++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 (>>=) #-}++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> KureM a+ fail = Failure+ {-# INLINE fail #-}+#endif++instance MonadFail KureM where+ 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` (\_ -> 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 monadic computation succeeds; succeed with @()@ if it fails.+notM :: MonadCatch m => m a -> m ()+notM ma = ifM (testM ma) (fail "notM of success") (return ())+{-# INLINE notM #-}++-- | 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 #-}++------------------------------------------------------------------------------------------++-- | The String is generated by 'show'ing the exception.+instance MonadCatch IO where+ catchM :: IO a -> (String -> IO a) -> IO a+ catchM io f = io `catch` (\ e -> f $ show (e :: SomeException))+ {-# INLINE catchM #-}++-- | Lift a computation from the 'IO' monad, catching failures in the target monad.+liftAndCatchIO :: (MonadCatch m, MonadIO m) => IO a -> m a+liftAndCatchIO io = join $ liftIO (liftM return io `catchM` (return . fail))+{-# INLINE liftAndCatchIO #-}++------------------------------------------------------------------------------------------
+ Language/KURE/Path.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- |+-- Module: Language.KURE.Path+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides several Path abstractions, used for denoting a path through the tree.++module Language.KURE.Path+ (+ -- * Paths+ -- | A @crumb@ is a value that denotes which child node to descended into.+ -- That is, a path through a tree is specified by a \"trail of breadcrumbs\".+ -- For example, if the children are numbered, 'Int' could be used as the @crumb@ type.+ -- 'SnocPath' is useful for recording where you have been, as it is cheap to keep adding to the end of the list as you travel further.+ -- 'Path' is useful for recording where you intend to go, as you'll need to access it in order.++ -- ** Relative Paths+ Path+ -- ** Snoc Paths+ , SnocPath(..)+ , ExtendPath(..)+ , snocPathToPath+ , pathToSnocPath+ , singletonSnocPath+ , lastCrumb+ -- ** Absolute and Local Paths+ , LocalPath+ , AbsolutePath+ , ReadPath(..)+ , lastCrumbT+ , absPathT+ )+where++import Control.Arrow ((>>^))++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Language.KURE.Transform+import Language.KURE.Combinators.Transform+import Language.KURE.Injection++-------------------------------------------------------------------------------++-- | A 'Path' is just a list.+-- The intent is that a path represents a route through the tree from an arbitrary node.+type Path crumb = [crumb]++-------------------------------------------------------------------------------++-- | A 'SnocPath' is a list stored in reverse order.+newtype SnocPath crumb = SnocPath [crumb] deriving Eq++instance Semigroup (SnocPath crumb) where+ (<>) :: SnocPath crumb -> SnocPath crumb -> SnocPath crumb+ (SnocPath p1) <> (SnocPath p2) = SnocPath (p2 ++ p1)+ {-# INLINE (<>) #-}++instance Monoid (SnocPath crumb) where+ mempty :: SnocPath crumb+ mempty = SnocPath []+ {-# INLINE mempty #-}++instance Functor SnocPath where+ fmap :: (a -> b) -> SnocPath a -> SnocPath b+ fmap f (SnocPath p) = SnocPath (map f p)+ {-# INLINE fmap #-}++-- | Convert a 'Path' to a 'SnocPath'. O(n).+pathToSnocPath :: Path crumb -> SnocPath crumb+pathToSnocPath p = SnocPath (reverse p)+{-# INLINE pathToSnocPath #-}++-- | Convert a 'SnocPath' to a 'Path'. O(n).+snocPathToPath :: SnocPath crumb -> Path crumb+snocPathToPath (SnocPath p) = reverse p+{-# INLINE snocPathToPath #-}++instance Show crumb => Show (SnocPath crumb) where+ show :: SnocPath crumb -> String+ show = show . snocPathToPath+ {-# INLINE show #-}++singletonSnocPath :: crumb -> SnocPath crumb+singletonSnocPath cr = SnocPath [cr]+{-# INLINE singletonSnocPath #-}++-- | Get the last crumb from a 'SnocPath'. O(1).+lastCrumb :: SnocPath crumb -> Maybe crumb+lastCrumb (SnocPath p) = safehead p+{-# INLINE lastCrumb #-}++-------------------------------------------------------------------------------++-- | A class of things that can be extended by crumbs.+-- Typically, @c@ is a context type.+-- The typical use is to extend an 'AbsolutePath' stored in the context (during tree traversal).+-- Note however, that if an 'AbsolutePath' is not stored in the context, an instance can still be declared with @('@@' crumb)@ as an identity operation.+class ExtendPath c crumb | c -> crumb where+ -- | Extend the current 'AbsolutePath' by one crumb.+ (@@) :: c -> crumb -> c++-- | A 'SnocPath' from the root.+type AbsolutePath = SnocPath++-- | A 'SnocPath' from a local origin.+type LocalPath = SnocPath++-- | A class for contexts that store the current 'AbsolutePath', allowing transformations to depend upon it.+class ReadPath c crumb | c -> crumb where+ -- | Read the current absolute path.+ absPath :: c -> AbsolutePath crumb++-- | Lifted version of 'absPath'.+absPathT :: (ReadPath c crumb, Monad m) => Transform c m a (AbsolutePath crumb)+absPathT = contextT >>^ absPath+{-# INLINE absPathT #-}++-- | Lifted version of 'lastCrumb'.+lastCrumbT :: (ReadPath c crumb, MonadFail m) => Transform c m a crumb+lastCrumbT = contextonlyT (projectWithFailMsgM (fail "lastCrumbT failed: at the root, no crumbs yet.") . lastCrumb . absPath)+{-# INLINE lastCrumbT #-}++-------------------------------------------------------------------------------++-- | Any 'SnocPath' can be extended.+instance ExtendPath (SnocPath crumb) crumb where+ (@@) :: SnocPath crumb -> crumb -> SnocPath crumb+ (SnocPath crs) @@ cr = SnocPath (cr:crs)+ {-# INLINE (@@) #-}++-- | The simplest instance of 'ReadPath' is 'AbsolutePath' itself.+instance ReadPath (AbsolutePath crumb) crumb where+ absPath :: AbsolutePath crumb -> AbsolutePath crumb+ absPath = id+ {-# INLINE absPath #-}++-------------------------------------------------------------------------------++safehead :: [a] -> Maybe a+safehead [] = Nothing+safehead (a:_) = Just a+{-# INLINE safehead #-}++-------------------------------------------------------------------------------
+ Language/KURE/Pathfinder.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module: Language.KURE.Pathfinder+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides combinators to find 'LocalPath's sub-nodes specified by a predicate.++module Language.KURE.Pathfinder+ (+ -- * Finding Local Paths+ -- ** Context Transformers+ -- | To find a 'LocalPath' to a node that satisfies a predicate, use @'withLocalPathT' (tt ('acceptLocalPathT' q))@,+ -- where @q@ is a transformation returning 'Bool', and @tt@ is a traversal strategy, such as 'collectT' or 'onetdT'.+ -- This will handle the tracking of the local path.+ -- See the example pathfinders below.+ WithLocalPath+ , withLocalPathT+ , exposeLocalPathT+ , acceptLocalPathT+ -- ** Example Pathfinders+ , pathsToT+ , onePathToT+ , oneNonEmptyPathToT+ , prunePathsToT+ , uniquePathToT+ , uniquePrunePathToT+) where++import Prelude++import Control.Category hiding ((.))+import Control.Arrow++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Language.KURE.MonadCatch+import Language.KURE.Transform+import Language.KURE.Combinators.Transform+import Language.KURE.Path+import Language.KURE.Walker+import Language.KURE.ExtendableContext++-------------------------------------------------------------------------------++-- | A context transformer that adds a 'LocalPath' (from the current node) to the context.+type WithLocalPath c crumb = ExtendContext c (LocalPath crumb)++-- | Apply a transformation that stores a 'LocalPath' in the context (starting at the current node).+withLocalPathT :: Transform (WithLocalPath c crumb) m a b -> Transform c m a b+withLocalPathT = liftContext (extendContext mempty)+{-# INLINE withLocalPathT #-}++-- | Extract the current 'LocalPath' from the context.+exposeLocalPathT :: Monad m => Transform (WithLocalPath c crumb) m a (LocalPath crumb)+exposeLocalPathT = contextT >>^ extraContext+{-# INLINE exposeLocalPathT #-}++-- | Return the current 'LocalPath' if the predicate transformation succeeds.+acceptLocalPathT :: MonadFail m => Transform c m u Bool -> Transform (WithLocalPath c crumb) m u (LocalPath crumb)+acceptLocalPathT q = accepterR (liftContext baseContext q) >>> exposeLocalPathT+{-# INLINE acceptLocalPathT #-}++-------------------------------------------------------------------------------++-- | Find the 'LocalPath's to every node that satisfies the predicate.+pathsToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u [LocalPath crumb]+pathsToT q = withLocalPathT (collectT $ acceptLocalPathT q)+{-# INLINE pathsToT #-}++-- | Find the 'LocalPath's to every node that satisfies the predicate, ignoring nodes below successes.+prunePathsToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u [LocalPath crumb]+prunePathsToT q = withLocalPathT (collectPruneT $ acceptLocalPathT q)+{-# INLINE prunePathsToT #-}++-- | Find the 'LocalPath' to the first node that satisfies the predicate (in a pre-order traversal).+onePathToT :: forall c crumb u m. (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)+onePathToT q = setFailMsg "No matching nodes found." $+ withLocalPathT (onetdT $ acceptLocalPathT q)+{-# INLINE onePathToT #-}++-- | Find the 'LocalPath' to the first descendent node that satisfies the predicate (in a pre-order traversal).+oneNonEmptyPathToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)+oneNonEmptyPathToT q = setFailMsg "No matching nodes found." $+ withLocalPathT (oneT $ onetdT $ acceptLocalPathT q)+{-# INLINE oneNonEmptyPathToT #-}+++-- local function used by uniquePathToT and uniquePrunePathToT+requireUniquePath :: MonadFail m => Transform c m [LocalPath crumb] (LocalPath crumb)+requireUniquePath = contextfreeT $ \ ps -> case ps of+ [] -> fail "No matching nodes found."+ [p] -> return p+ _ -> fail $ "Ambiguous: " ++ show (length ps) ++ " matching nodes found."+{-# INLINE requireUniquePath #-}++-- | Find the 'LocalPath' to the node that satisfies the predicate, failing if that does not uniquely identify a node.+uniquePathToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)+uniquePathToT q = pathsToT q >>> requireUniquePath+{-# INLINE uniquePathToT #-}++-- | Build a 'LocalPath' to the node that satisfies the predicate, failing if that does not uniquely identify a node (ignoring nodes below successes).+uniquePrunePathToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)+uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath+{-# INLINE uniquePrunePathToT #-}++-------------------------------------------------------------------------------
− Language/KURE/Rewrite.hs
@@ -1,46 +0,0 @@--- |--- Module: Language.KURE.Rewrite --- Copyright: (c) 2006-2008 Andy Gill--- License: BSD3------ Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable--- Portability: ghc------ 'Rewrite' is a synonoym for a 'Translate' with the same source and target type.--- This module contains the defintion of Rewrite, and some aliases for some translate functions that use --- Rewrite rather than Translate.--module Language.KURE.Rewrite - ( Rewrite- , rewrite- , runRewrite- ) where--import Language.KURE.RewriteMonad-import Language.KURE.Translate-import Data.Monoid---- | A 'Rewrite' is a 'Translate' that shares the same source and target type. Literally, --- a 'Rewrite' provides the details about how to /re-write/ a specific type.--type Rewrite m dec exp = Translate m dec exp exp---- | 'rewrite' is our primitive way of building a Rewrite,--- where if the rewrite is successful it is automatically marked as a non-identity rewrite. ------ @rewrite $ \\ _ e -> return e@ /is not/ an identity rewrite. --rewrite :: (Monoid dec, Monad m) => (exp1 -> RewriteM m dec exp1) -> Rewrite m dec exp1-rewrite = translate---- | 'runRewrite' executes the rewrite, returning either a failure message,--- or a success and the new parts of the environment.---runRewrite :: (Monoid dec,Monad m) - => Rewrite m dec exp- -> dec - -> exp - -> m (Either String (exp,dec,Int))-runRewrite = runTranslate
− Language/KURE/RewriteMonad.hs
@@ -1,165 +0,0 @@--- |--- Module: Language.KURE.RewriteMonad --- Copyright: (c) 2006-2008 Andy Gill--- License: BSD3------ Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable--- Portability: ghc------ This is the definition of the monad inside KURE.--module Language.KURE.RewriteMonad - ( RewriteM -- abstract- , RewriteStatusM(..)- , Count(..)- , theCount- , runRewriteM- , failM- , catchM- , chainM- , liftQ- , markM- , transparentlyM- , readEnvM- , mapEnvM- , writeEnvM- ) where ---import Control.Monad-import Data.Monoid----------------------------------------------------------------------------------data RewriteM m dec exp = - RewriteM { -- | 'runRewriteM' runs the 'RewriteM' monad, returning a status.- runRewriteM :: dec -> m (RewriteStatusM dec exp) - }---data Count = LoneTransform- | Count !Int---- | How many transformations have been performed?--theCount :: Count -> Int -theCount (LoneTransform) = 1-theCount (Count n) = n--instance Monoid Count where- mempty = Count 0-- mappend (Count 0) other = other- mappend other (Count 0) = other- mappend (Count i1) (Count i2) = Count (i1 + i2)- mappend (LoneTransform) (Count i2) = Count $ succ i2- mappend (Count i1) (LoneTransform) = Count $ succ i1- mappend (LoneTransform) (LoneTransform) = Count $ 2--data RewriteStatusM dec exp- = RewriteReturnM exp !(Maybe dec) !Count -- ^ a regular success- | RewriteFailureM String -- ^ a real failure--- | RewriteIdM exp -- ^ identity marker on a value----- TWO possible ways of thinking about rewriting:---- C1 (e1) => C2 (C1 (e2)) => C3 (C2 (C1 (e3))) -- matches the *writer* like status--- C1 (e1) => C1 (C2 (e2)) => C1 (C2 (C3 (e3))) -- will require mergeing??--instance (Monoid dec,Monad m) => Monad (RewriteM m dec) where- return e = RewriteM $ \ _ -> return $ RewriteReturnM e Nothing mempty- (RewriteM m) >>= k = RewriteM $ \ dec -> do- r <- m dec- case r of- RewriteReturnM r1 ds ids -> do- r2 <- runRewriteM (k r1) dec- return $ case r2 of- RewriteReturnM e' ds' ids' -> RewriteReturnM e' (ds' `mappend` ds) (ids' `mappend` ids)- RewriteFailureM msg -> RewriteFailureM msg- RewriteFailureM msg -> return $ RewriteFailureM msg-- fail msg = RewriteM $ \ _ -> return $ RewriteFailureM msg--instance (Monoid dec,Monad m) => Functor (RewriteM m dec) where- fmap f m = liftM f m---- | 'liftQ' lets you tunnel into the inner monad, because 'RewriteM' is actually monad transformer.-liftQ :: (Monad m,Monoid dec) => m a -> RewriteM m dec a -liftQ m = RewriteM $ \ _ -> do r <- m- return $ RewriteReturnM r mempty mempty---- | 'failM' is our basic failure, with a String message.-failM :: (Monad m, Monoid dec) => String -> RewriteM m dec a-failM msg = RewriteM $ \ _ -> return $ RewriteFailureM msg---- | 'catchM' catches failures, and tries a second monadic computation.-catchM :: (Monad m) => RewriteM m dec a -> (String -> RewriteM m dec a) -> RewriteM m dec a-catchM (RewriteM m1) m2 = RewriteM $ \ dec -> do- r <- m1 dec- case r of- RewriteReturnM {} -> return r - RewriteFailureM msg -> runRewriteM (m2 msg) dec- - --- | 'chainM' executes the first argument then the second, much like '>>=',--- except that the second computation can see if the first computation was an identity or not.--- Used to spot when a rewrite succeeded, but was the identity.--chainM :: (Monoid dec,Monad m) - => (RewriteM m dec b) - -> (Int -> b -> RewriteM m dec c)- -> RewriteM m dec c-chainM m k = RewriteM $ \ dec -> do- r <- runRewriteM m dec- case r of- RewriteReturnM a ds ids -> - do r2 <- runRewriteM (k (theCount ids) a) - (case ds of- Nothing -> dec- Just ds2 -> ds2 `mappend` dec)- case r2 of- RewriteReturnM a' ds' ids' ->- return $ RewriteReturnM a' (ds' `mappend` ds) (ids' `mappend` ids)- RewriteFailureM msg -> return $ RewriteFailureM msg- RewriteFailureM msg -> return $ RewriteFailureM msg -- and still fail --- --- | 'markM' is used to mark a monadic rewrite as a non-identity,--- unless the congruence flag is set.-markM :: (Monad m) => RewriteM m dec a -> RewriteM m dec a-markM (RewriteM m) = RewriteM $ \ dec -> do- r <- m dec- case r of- RewriteReturnM a ds (Count 0) -> return $ RewriteReturnM a ds LoneTransform- RewriteReturnM a ds (Count n) -> return $ RewriteReturnM a ds (Count $ succ n)- RewriteReturnM a ds (LoneTransform) -> return $ RewriteReturnM a ds (Count 2)- RewriteFailureM msg -> return $ RewriteFailureM msg- --- | 'transparently' sets the congruence flag, such that if the--- monadic action was identity preserving, then a 'markM' does--- not set the non-indentity flag.- -transparentlyM :: (Monad m) => RewriteM m dec a -> RewriteM m dec a-transparentlyM (RewriteM m) = RewriteM $ \ dec -> do- r <- m dec- case r of- RewriteReturnM a ds LoneTransform -> return $ RewriteReturnM a ds (Count 0)- RewriteReturnM a ds other -> return $ RewriteReturnM a ds other- RewriteFailureM msg -> return $ RewriteFailureM msg---- | 'getDecsM' reads the local environment-readEnvM :: (Monad m, Monoid dec) => RewriteM m dec dec-readEnvM = RewriteM $ \ dec -> return $ RewriteReturnM dec mempty mempty---- | 'mapDecs' changes the local environment, inside a local monadic invocation.-mapEnvM :: (Monad m, Monoid dec) => (dec -> dec) -> RewriteM m dec a -> RewriteM m dec a-mapEnvM fn (RewriteM m) = RewriteM $ \ dec -> m (fn dec)----- | 'writeDecM' writes a value to the writer monad inside the 'RewriteM'.-writeEnvM :: (Monad m,Monoid dec) => dec -> RewriteM m dec ()-writeEnvM dec = RewriteM $ \ _dec -> return $ RewriteReturnM () (Just dec) (Count 0)-
− Language/KURE/Term.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}---- | This module supports the generic walking of 'Term's. ------ The key idea here is that for each type of expression (@exp@), --- we have a sum of all the interesting children types (@Generic exp@).--- There is always a type that its own 'Generic', which is used for the --- deeper syntax tree walks.--module Language.KURE.Term - ( Term(..)- , Walker(..)- , extractR- , promoteR- , extractU- , promoteU- , topdownR- , bottomupR - , alltdR - , downupR - , innermostR - , foldU - ) where- -import Language.KURE.Translate -import Language.KURE.Rewrite-import Language.KURE.Combinators--import Control.Monad-import Data.Monoid---- | 'Term's are things that syntax are built from.-class Term exp where- -- | 'Generic' is a sum of all the interesting sub-types, transitively, of @exp@. - -- We use @Generic e ~ e@ to signify that something is its own Generic.- -- Simple expression types might be their own sole 'Generic', more complex examples- -- will have a new datatype for the 'Generic', which will also be an instance of class 'Term'.- type Generic exp-- -- | 'project' projects into a 'Generic', to get the exp inside, or fails.- select :: Generic exp -> Maybe exp-- -- | 'inject' injects an exp into a 'Generic'.- inject :: exp -> Generic exp----- | 'Walker' captures how we walk over @exp@, using a specific @m@ and @dec@.-class (Monoid dec,Monad m,Term exp) => Walker m dec exp where- -- | 'allR' applies 'Generic' rewrites to all the interesting children of this node.- allR :: Rewrite m dec (Generic exp) -> Rewrite m dec exp- -- | 'allU' applied a 'Generic' Translation to a common, 'Monoid'al result, to all the interesting children of this node.- crushU :: (Monoid result) => Translate m dec (Generic exp) result -> Translate m dec exp result------------------------------------------------------------------------------------ | 'extractR' converts a 'Rewrite' over a 'Generic' into a rewrite over a specific expression type. --extractR :: (Monad m, Term exp, Monoid dec) => Rewrite m dec (Generic exp) -> Rewrite m dec exp -- at *this* type-extractR rr = transparently $ rewrite $ \ e -> do- e' <- apply rr (inject e)- case select e' of- Nothing -> fail "extractR"- Just r -> return r- --- | 'extractU' converts a 'Translate' taking a 'Generic' into a translate over a specific expression type. --extractU :: (Monad m, Term exp, Monoid dec) => Translate m dec (Generic exp) r -> Translate m dec exp r-extractU rr = transparently $ translate $ \ e -> apply rr (inject e)---- | 'promoteR' promotes a 'Rewrite' into a 'Generic' 'Rewrite'; other types inside Generic cause failure.--- 'try' can be used to convert a failure-by-default promotion into a 'id-by-default' promotion.--promoteR :: (Monad m, Term exp, Monoid dec) => Rewrite m dec exp -> Rewrite m dec (Generic exp)-promoteR rr = transparently $ rewrite $ \ e -> do- case select e of- Nothing -> fail "promoteR"- Just e' -> do- r <- apply rr e'- return (inject r)---- | 'promoteU' promotes a 'Translate' into a 'Generic' 'Translate'; other types inside Generic cause failure.--promoteU :: (Monad m, Term exp, Monoid dec) => Translate m dec exp r -> Translate m dec (Generic exp) r-promoteU rr = transparently $ translate $ \ e -> do- case select e of- Nothing -> fail "promoteI"- Just e' -> apply rr e'------------------------------------------------------------------------------------- | apply a rewrite in a top down manner.-topdownR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-topdownR s = s >-> allR (topdownR s)---- | apply a rewrite in a bottom up manner.-bottomupR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-bottomupR s = allR (bottomupR s) >-> s---- | apply a rewrite in a top down manner, prunning at successful rewrites.-alltdR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-alltdR s = s <+ allR (alltdR s)---- | apply a rewrite twice, in a topdown and bottom up way, using one single tree traversal.-downupR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-downupR s = s >-> allR (downupR s) >-> s---- | a fixed point traveral, starting with the innermost term.-innermostR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)-innermostR s = bottomupR (tryR (s >-> innermostR s)) ---- fold a tree using a single translation for each node.-foldU :: (e ~ Generic e, Walker m dec e, Monoid r) => Translate m dec (Generic e) r -> Translate m dec (Generic e) r-foldU s = concatT [ s, crushU (foldU s) ]---------------------------------------------------------------------------------
+ Language/KURE/Transform.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE PolyKinds #-}+-- |+-- Module: Language.KURE.Transform+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module defines 'Transform' and 'Rewrite', the main KURE types.+-- 'Rewrite' is just a special case of 'Transform', and so any function that operates on 'Transform' is also+-- applicable to 'Rewrite'.+--+-- 'Transform' is an instance of the 'Monad' and 'Arrow' type-class families, and consequently+-- many of the desirable combinators over 'Transform' and 'Rewrite' are special cases+-- of existing monadic or arrow combinators.+-- "Language.KURE.Combinators" provides some additional combinators that aren't in the standard libraries.++module Language.KURE.Transform+ (-- * Transformations and Rewrites+ Transform, Translate+ , Rewrite+ , applyT, applyR, apply+ , transform, translate+ , rewrite+ , contextfreeT+ , contextonlyT+ , constT+ , effectfreeT+) where++import Prelude hiding (id, (.))++import Control.Applicative+import Control.Monad++#if !MIN_VERSION_base(4,13,0)+import qualified Control.Monad.Fail+import Control.Monad.Fail (MonadFail)+#endif++import Control.Monad.IO.Class+import Control.Category+import Control.Arrow++import Language.KURE.MonadCatch++------------------------------------------------------------------------------------------++-- | An abstract representation of a transformation from a value of type @a@ in a context @c@ to a monadic value of type @m b@.+-- The 'Transform' type is the basis of the entire KURE library.+newtype Transform c m a b = Transform { -- | Apply a transformation to a value and its context.+ applyT :: c -> a -> m b}++-- | A deprecated synonym for 'Transform'.+type Translate c m a b = Transform c m a b++-- | The primitive way of building a transformation.+transform :: (c -> a -> m b) -> Transform c m a b+transform = Transform+{-# INLINE transform #-}++-- | A deprecated synonym for 'transform'.+translate :: (c -> a -> m b) -> Translate c m a b+translate = transform+{-# INLINE translate #-}+{-# DEPRECATED translate "Please use 'transform' instead." #-}++-- | A transformation that shares the same source and target type.+type Rewrite c m a = Transform c m a a++-- | The primitive way of building a rewrite.+rewrite :: (c -> a -> m a) -> Rewrite c m a+rewrite = transform+{-# INLINE rewrite #-}++-- | Apply a rewrite to a value and its context.+applyR :: Rewrite c m a -> c -> a -> m a+applyR = applyT+{-# INLINE applyR #-}++-- | A deprecated synonym for 'applyT'.+apply :: Transform c m a b -> c -> a -> m b+apply = applyT+{-# INLINE apply #-}+{-# DEPRECATED apply "Please use 'applyT' instead." #-}++------------------------------------------------------------------------------------------++-- | Build a 'Transform' that doesn't depend on the context.+contextfreeT :: (a -> m b) -> Transform c m a b+contextfreeT f = transform (\ _ -> f)+{-# INLINE contextfreeT #-}++-- | Build a 'Transform' that doesn't depend on the value.+contextonlyT :: (c -> m b) -> Transform c m a b+contextonlyT f = transform (\ c _ -> f c)+{-# INLINE contextonlyT #-}++-- | Build a constant 'Transform' from a monadic computation.+constT :: m b -> Transform c m a b+constT = contextfreeT . const+{-# INLINE constT #-}++-- | Build a 'Transform' that doesn't perform any monadic effects.+effectfreeT :: Monad m => (c -> a -> b) -> Transform c m a b+effectfreeT f = transform ( \ c a -> return (f c a))+{-# INLINE effectfreeT #-}++------------------------------------------------------------------------------------------++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Functor m => Functor (Transform c m a) where+ fmap :: (b -> d) -> Transform c m a b -> Transform c m a d+ fmap f t = transform (\ c -> fmap f . applyT t c)+ {-# INLINE fmap #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Applicative m => Applicative (Transform c m a) where+ pure :: b -> Transform c m a b+ pure = constT . pure+ {-# INLINE pure #-}++ (<*>) :: Transform c m a (b -> d) -> Transform c m a b -> Transform c m a d+ tf <*> tb = transform (\ c a -> applyT tf c a <*> applyT tb c a)+ {-# INLINE (<*>) #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Alternative m => Alternative (Transform c m a) where+ empty :: Transform c m a b+ empty = constT empty+ {-# INLINE empty #-}++ (<|>) :: Transform c m a b -> Transform c m a b -> Transform c m a b+ t1 <|> t2 = transform (\ c a -> applyT t1 c a <|> applyT t2 c a)+ {-# INLINE (<|>) #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance Monad m => Monad (Transform c m a) where+ return :: b -> Transform c m a b+ return = constT . return+ {-# INLINE return #-}++ (>>=) :: Transform c m a b -> (b -> Transform c m a d) -> Transform c m a d+ t >>= f = transform $ \ c a -> do b <- applyT t c a+ applyT (f b) c a+ {-# INLINE (>>=) #-}++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> Transform c m a b+ fail = constT . fail+ {-# INLINE fail #-}+#endif++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadFail m => MonadFail (Transform c m a) where+ fail :: String -> Transform c m a b+ fail = constT . fail+ {-# INLINE fail #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadCatch m => MonadCatch (Transform c m a) where+ catchM :: Transform c m a b -> (String -> Transform c m a b) -> Transform c m a b+ catchM t1 t2 = transform $ \ c a -> applyT t1 c a `catchM` \ msg -> applyT (t2 msg) c a+ {-# INLINE catchM #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadPlus m => MonadPlus (Transform c m a) where+ mzero :: Transform c m a b+ mzero = constT mzero+ {-# INLINE mzero #-}++ mplus :: Transform c m a b -> Transform c m a b -> Transform c m a b+ mplus t1 t2 = transform $ \ c a -> applyT t1 c a `mplus` applyT t2 c a+ {-# INLINE mplus #-}++-- | Lifting through a Reader transformer, where (c,a) is the read-only environment.+instance MonadIO m => MonadIO (Transform c m a) where+ liftIO :: IO b -> Transform c m a b+ liftIO = constT . liftIO+ {-# INLINE liftIO #-}++------------------------------------------------------------------------------------------++-- | The 'Kleisli' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => Category (Transform c m) where+ id :: Transform c m a a+ id = contextfreeT return+ {-# INLINE id #-}++ (.) :: Transform c m b d -> Transform c m a b -> Transform c m a d+ t2 . t1 = transform (\ c -> applyT t1 c >=> applyT t2 c)+ {-# INLINE (.) #-}++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => Arrow (Transform c m) where+ arr :: (a -> b) -> Transform c m a b+ arr f = contextfreeT (return . f)+ {-# INLINE arr #-}++ first :: Transform c m a b -> Transform c m (a,z) (b,z)+ first t = transform $ \ c (a,z) -> liftM (\ b -> (b,z)) (applyT t c a)+ {-# INLINE first #-}++ second :: Transform c m a b -> Transform c m (z,a) (z,b)+ second t = transform $ \ c (z,a) -> liftM (\ b -> (z,b)) (applyT t c a)+ {-# INLINE second #-}++ (***) :: Transform c m a1 b1 -> Transform c m a2 b2 -> Transform c m (a1,a2) (b1,b2)+ t1 *** t2 = transform $ \ c (a,b) -> liftM2 (,) (applyT t1 c a) (applyT t2 c b)+ {-# INLINE (***) #-}++ (&&&) :: Transform c m a b1 -> Transform c m a b2 -> Transform c m a (b1,b2)+ t1 &&& t2 = transform $ \ c a -> liftM2 (,) (applyT t1 c a) (applyT t2 c a)+ {-# INLINE (&&&) #-}++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance MonadPlus m => ArrowZero (Transform c m) where+ zeroArrow :: Transform c m a b+ zeroArrow = mzero+ {-# INLINE zeroArrow #-}++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance MonadPlus m => ArrowPlus (Transform c m) where+ (<+>) :: Transform c m a b -> Transform c m a b -> Transform c m a b+ (<+>) = mplus+ {-# INLINE (<+>) #-}++-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment.+instance Monad m => ArrowApply (Transform c m) where+ app :: Transform c m (Transform c m a b, a) b+ app = transform (\ c (t,a) -> applyT t c a)+ {-# INLINE app #-}++------------------------------------------------------------------------------------------++-- | Lifting through the 'Monad' and a Reader transformer, where (c,a) is the read-only environment.+instance (Applicative m, Semigroup b) => Semigroup (Transform c m a b) where+ (<>) :: Transform c m a b -> Transform c m a b -> Transform c m a b+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}++-- | Lifting through the 'Monad' and a Reader transformer, where (c,a) is the read-only environment.+instance (Monad m, Monoid b) => Monoid (Transform c m a b) where+ mempty :: Transform c m a b+ mempty = return mempty+ {-# INLINE mempty #-}++------------------------------------------------------------------------------------------
− Language/KURE/Translate.hs
@@ -1,70 +0,0 @@--- |--- Module: Language.KURE.Translate --- Copyright: (c) 2006-2008 Andy Gill--- License: BSD3------ Maintainer: Andy Gill <andygill@ku.edu>--- Stability: unstable--- Portability: ghc------ 'Translate' is the main abstraction inside KURE, and represents a rewriting from a source to a target--- of a possibly different type.------ Rewrite (defined in 'Language.KURE.Rewrite') is a synonoym for a 'Translate' with the same source and target type.--module Language.KURE.Translate - ( Translate- , apply- , runTranslate- , transparently- , translate- ) where- -import Control.Monad-import Data.Monoid--import Language.KURE.RewriteMonad---- | 'Translate' is a translation or strategy that translates between @exp1@ and @exp2@, with the posiblity of failure,--- and remembers identity translations.--newtype Translate m dec exp1 exp2 =- Translate ( exp1 -> RewriteM m dec exp2 )---- | 'apply' directly applies a 'Translate' value to an argument.-apply :: (Monoid dec, Monad m) => Translate m dec exp1 exp2 -> exp1 -> RewriteM m dec exp2-apply (Translate t) exp1 = t exp1 ---- | 'translate' is the standard way of building a 'Translate', where if the translation is successful it --- is automatically marked as a non-identity translation. ------ Note: @translate $ \\ e -> return e@ /is not/ an identity rewrite, but a succesful rewrite that--- returns its provided argument. --translate :: (Monoid dec, Monad m) => (exp1 -> RewriteM m dec exp2) -> Translate m dec exp1 exp2-translate f = Translate $ \ e -> markM $ f e----- | 'transparently' marks a 'translate' (or 'rewrite') as transparent, that is the identity status--- of any internal applications of 'apply' is preserved across the translate.------ Note: @transparently $ translate $ \\ e -> return e@ /is/ an identity rewrite.--transparently :: (Monoid dec, Monad m) => Translate m dec exp1 exp2 -> Translate m dec exp1 exp2-transparently (Translate m) = Translate $ \ e -> transparentlyM (m e)---- | 'runTranslate' executes the translation, returning either a failure message,--- or a success and the new parts of the environment.--runTranslate :: (Monoid dec,Monad m) - => Translate m dec exp res- -> dec - -> exp - -> m (Either String (res,dec,Int))-runTranslate rr dec e = do- res <- runRewriteM (apply rr e) dec- case res of- RewriteReturnM exp' Nothing c -> return (Right (exp',mempty,theCount c))- RewriteReturnM exp' (Just ds) c -> return (Right (exp',ds,theCount c))- RewriteFailureM msg -> return (Left msg)-
+ Language/KURE/Walker.hs view
@@ -0,0 +1,637 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+-- |+-- Module: Language.KURE.Walker+-- Copyright: (c) 2012--2021 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+-- Stability: beta+-- Portability: ghc+--+-- This module provides combinators that traverse a tree.+--+-- Note that all traversals take place on the node, its children, or its descendents.+-- Deliberately, there is no mechanism for \"ascending\" the tree.++module Language.KURE.Walker+ (+ -- * Shallow Traversals++ -- ** Tree Walkers+ Walker(..)+ -- ** Child Transformations+ , childR+ , childT++ -- * Deep Traversals++ -- ** Traversals for Rewrites+ , alltdR+ , allbuR+ , allduR+ , anytdR+ , anybuR+ , anyduR+ , onetdR+ , onebuR+ , prunetdR+ , innermostR+ , allLargestR+ , anyLargestR+ , oneLargestR++ -- ** Traversals for Transformations+ , foldtdT+ , foldbuT+ , onetdT+ , onebuT+ , prunetdT+ , crushtdT+ , crushbuT+ , collectT+ , collectPruneT+ , allLargestT+ , oneLargestT++ -- * Utilitity Transformations+ , childrenT+ , summandIsTypeT++ -- * Paths+ -- ** Building Lenses from Paths+ , pathL+ , localPathL+ , exhaustPathL+ , repeatPathL+ -- ** Applying transformations at the end of Paths+ , pathR+ , pathT+ , localPathR+ , localPathT+ -- ** Testing Paths+ , testPathT+) where++import Prelude hiding (id)++import Data.Maybe (isJust)+import Data.Monoid ()+import Data.DList (singleton, toList)++import Control.Arrow+import Control.Category hiding ((.))+import Control.Monad (liftM, ap, mplus)++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail+#endif++import Language.KURE.MonadCatch+import Language.KURE.Transform+import Language.KURE.Lens+import Language.KURE.Injection+import Language.KURE.Combinators+import Language.KURE.Path++-------------------------------------------------------------------------------++-- | 'Walker' captures the ability to walk over a tree containing nodes of type @u@,+-- using a specific context @c@.+--+-- Minimal complete definition: 'allR'.+--+-- Default definitions are provided for 'anyR', 'oneR', 'allT', 'oneT', and 'childL',+-- but they may be overridden for efficiency.++class Walker c u where+ -- | Apply a rewrite to all immediate children, succeeding if they all succeed.+ allR :: MonadCatch m => Rewrite c m u -> Rewrite c m u++ -- | Apply a transformation to all immediate children, succeeding if they all succeed.+ -- The results are combined in a 'Monoid'.+ allT :: (MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b+ allT = unwrapAllT . allR . wrapAllT+ {-# INLINE allT #-}++ -- | Apply a transformation to the first immediate child for which it can succeed.+ oneT :: MonadCatch m => Transform c m u b -> Transform c m u b+ oneT = unwrapOneT . allR . wrapOneT+ {-# INLINE oneT #-}++ -- | Apply a rewrite to all immediate children, suceeding if any succeed.+ anyR :: MonadCatch m => Rewrite c m u -> Rewrite c m u+ anyR = unwrapAnyR . allR . wrapAnyR+ {-# INLINE anyR #-}++ -- | Apply a rewrite to the first immediate child for which it can succeed.+ oneR :: MonadCatch m => Rewrite c m u -> Rewrite c m u+ oneR = unwrapOneR . allR . wrapOneR+ {-# INLINE oneR #-}++ -- | Construct a 'Lens' to the n-th child node.+ childL :: (ReadPath c crumb, Eq crumb, MonadCatch m) => crumb -> Lens c m u u+ childL = childL_default+ {-# INLINE childL #-}++------------------------------------------------------------------------------------------++-- | List the children of the current node.+childrenT :: (ReadPath c crumb, Walker c u, MonadCatch m) => Transform c m u [crumb]+childrenT = allT (lastCrumbT >>^ return)+{-# INLINE childrenT #-}++-------------------------------------------------------------------------------++-- | Apply a transformation to a specified child.+childT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => crumb -> Transform c m u b -> Transform c m u b+childT n = focusT (childL n)+{-# INLINE childT #-}++-- | Apply a rewrite to a specified child.+childR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => crumb -> Rewrite c m u -> Rewrite c m u+childR n = focusR (childL n)+{-# INLINE childR #-}++-------------------------------------------------------------------------------++-- | Fold a tree in a top-down manner, using a single 'Transform' for each node.+foldtdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b+foldtdT t = prefixFailMsg "foldtdT failed: " $+ let go = t <> allT go+ in go+{-# INLINE foldtdT #-}++-- | Fold a tree in a bottom-up manner, using a single 'Transform' for each node.+foldbuT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b+foldbuT t = prefixFailMsg "foldbuT failed: " $+ let go = allT go <> t+ in go+{-# INLINE foldbuT #-}++-- | Apply a transformation to the first node for which it can succeed, in a top-down traversal.+onetdT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u b+onetdT t = setFailMsg "onetdT failed" $+ let go = t <+ oneT go+ in go+{-# INLINE onetdT #-}++-- | Apply a transformation to the first node for which it can succeed, in a bottom-up traversal.+onebuT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u b+onebuT t = setFailMsg "onebuT failed" $+ let go = oneT go <+ t+ in go+{-# INLINE onebuT #-}++-- | Attempt to apply a 'Transform' in a top-down manner, pruning at successes.+prunetdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u 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 u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b+crushtdT t = foldtdT (mtryM t)+{-# INLINE crushtdT #-}++-- | An always successful bottom-up fold, replacing failures with 'mempty'.+crushbuT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b+crushbuT t = foldbuT (mtryM t)+{-# INLINE crushbuT #-}++-- | An always successful traversal that collects the results of all successful applications of a 'Transform' in a list.+collectT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u [b]+collectT t = crushtdT (t >>^ singleton) >>^ toList+{-# INLINE collectT #-}++-- | Like 'collectT', but does not traverse below successes.+collectPruneT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u [b]+collectPruneT t = prunetdT (t >>^ singleton) >>^ toList+{-# INLINE collectPruneT #-}++-------------------------------------------------------------------------------++-- | Apply a rewrite in a top-down manner, succeeding if they all succeed.+alltdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Rewrite c m u -> Rewrite c m u+innermostR r = setFailMsg "innermostR failed" $+ let go = anybuR (r >>> tryR go)+ in go+{-# INLINE innermostR #-}++-------------------------------------------------------------------------------++tryL :: MonadCatch m => Lens c m u u -> Lens c m u u+tryL l = l `catchL` (\ _ -> id)+{-# INLINE tryL #-}++-- | Construct a 'Lens' by following a 'Path'.+pathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u+pathL = serialise . map childL+{-# INLINE pathL #-}++-- | Build a 'Lens' from the root to a point specified by a 'LocalPath'.+localPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Lens c m u u+localPathL = pathL . snocPathToPath+{-# INLINE localPathL #-}++-- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed.+exhaustPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u+exhaustPathL = foldr (\ n l -> tryL (childL n >>> l)) id+{-# INLINE exhaustPathL #-}++-- | Repeat as many iterations of the 'Path' as possible.+repeatPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u+repeatPathL p = let go = tryL (pathL p >>> go)+ in go+{-# INLINE repeatPathL #-}++-------------------------------------------------------------------------------++-- | Apply a rewrite at a point specified by a 'Path'.+pathR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Rewrite c m u -> Rewrite c m u+pathR = focusR . pathL+{-# INLINE pathR #-}++-- | Apply a transformation at a point specified by a 'Path'.+pathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Transform c m u b -> Transform c m u b+pathT = focusT . pathL+{-# INLINE pathT #-}++-- | Apply a rewrite at a point specified by a 'LocalPath'.+localPathR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Rewrite c m u -> Rewrite c m u+localPathR = focusR . localPathL+{-# INLINE localPathR #-}++-- | Apply a transformation at a point specified by a 'LocalPath'.+localPathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Transform c m u b -> Transform c m u b+localPathT = focusT . localPathL+{-# INLINE localPathT #-}++-------------------------------------------------------------------------------++-- | Check if it is possible to construct a 'Lens' along this path from the current node.+testPathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Transform c m u 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 u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u+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 u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u+oneLargestR p r = setFailMsg "oneLargestR failed" $+ let go = ifM p r (oneR go)+ in go+{-# INLINE oneLargestR #-}++-- | Apply a transformation to the largest node(s) that satisfy the predicate, combining the results in a monoid.+allLargestT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u Bool -> Transform c m u b -> Transform c m u b+allLargestT p t = prefixFailMsg "allLargestT failed: " $+ let go = ifM p t (allT go)+ in go+{-# INLINE allLargestT #-}++-- | Apply a transformation to the first node for which it can succeed among the largest node(s) that satisfy the predicate.+oneLargestT :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Transform c m u b -> Transform c m u 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 u. (MonadCatch m, Injection a u) => a -> Transform c m u Bool+summandIsTypeT _ = arr (isJust . (project :: (u -> Maybe a)))+{-# INLINE summandIsTypeT #-}++-------------------------------------------------------------------------------++data P a b = P a b++pSnd :: P a b -> b+pSnd (P _ b) = b+{-# INLINE pSnd #-}++checkSuccessPMaybe :: MonadFail 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) => Functor (AllT w m) where+ fmap :: (a -> b) -> AllT w m a -> AllT w m b+ fmap = liftM+ {-# INLINE fmap #-}++instance (Monoid w, Monad m) => Applicative (AllT w m) where+ pure :: a -> AllT w m a+ pure = return+ {-# INLINE pure #-}++ (<*>) :: AllT w m (a -> b) -> AllT w m a -> AllT w m b+ (<*>) = ap+ {-# INLINE (<*>) #-}++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 #-}++ (>>=) :: 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 (>>=) #-}++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> AllT w m a+ fail = AllT . fail+ {-# INLINE fail #-}+#endif++instance (Monoid w, MonadFail m) => MonadFail (AllT w m) where+ fail :: String -> AllT w m a+ fail = AllT . fail+ {-# INLINE fail #-}++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 'Transform' using the 'AllT' monad transformer.+wrapAllT :: Monad m => Transform c m u b -> Rewrite c (AllT b m) u+wrapAllT t = readerT $ \ a -> resultT (AllT . liftM (P a)) t+{-# INLINE wrapAllT #-}++-- | Unwrap a 'Transform' from the 'AllT' monad transformer.+unwrapAllT :: MonadCatch m => Rewrite c (AllT b m) u -> Transform c m u 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 => Functor (OneT w m) where+ fmap :: (a -> b) -> OneT w m a -> OneT w m b+ fmap = liftM+ {-# INLINE fmap #-}++instance Monad m => Applicative (OneT w m) where+ pure :: a -> OneT w m a+ pure = return+ {-# INLINE pure #-}++ (<*>) :: OneT w m (a -> b) -> OneT w m a -> OneT w m b+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad m => Monad (OneT w m) where+ return :: a -> OneT w m a+ return a = OneT $ \ mw -> return (P a mw)+ {-# INLINE return #-}++ (>>=) :: 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 (>>=) #-}++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> OneT w m a+ fail msg = OneT (\ _ -> fail msg)+ {-# INLINE fail #-}+#endif++instance MonadFail m => MonadFail (OneT w m) where+ fail :: String -> OneT w m a+ fail msg = OneT (\ _ -> fail msg)+ {-# INLINE fail #-}++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 'Transform' using the 'OneT' monad transformer.+wrapOneT :: MonadCatch m => Transform c m u b -> Rewrite c (OneT b m) u+wrapOneT t = rewrite $ \ c a -> OneT $ \ mw -> case mw of+ Just w -> return (P a (Just w))+ Nothing -> ((P a . Just) `liftM` applyT t c a) <+ return (P a mw)+{-# INLINE wrapOneT #-}++-- | Unwrap a 'Transform' from the 'OneT' monad transformer.+unwrapOneT :: MonadFail m => Rewrite c (OneT b m) u -> Transform c m u b+unwrapOneT = resultT (checkSuccessPMaybe "oneT failed" . liftM pSnd . ($ Nothing) . unOneT)+{-# INLINE unwrapOneT #-}++-------------------------------------------------------------------------------++-- If allR just used Monad (rather than MonadCatch), this (and other things) would be 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.++data GetChild c u a = GetChild (KureM a) (Maybe (c,u))++getChildSecond :: (Maybe (c,u) -> Maybe (c,u)) -> GetChild c u a -> GetChild c u a+getChildSecond f (GetChild ka mcu) = GetChild ka (f mcu)+{-# INLINE getChildSecond #-}++instance Functor (GetChild c u) where+ fmap :: (a -> b) -> GetChild c u a -> GetChild c u b+ fmap = liftM+ {-# INLINE fmap #-}++instance Applicative (GetChild c u) where+ pure :: a -> GetChild c u a+ pure = return+ {-# INLINE pure #-}++ (<*>) :: GetChild c u (a -> b) -> GetChild c u a -> GetChild c u b+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad (GetChild c u) where+ return :: a -> GetChild c u a+ return a = GetChild (return a) Nothing+ {-# INLINE return #-}++ (>>=) :: GetChild c u a -> (a -> GetChild c u b) -> GetChild c u b+ (GetChild kma mcu) >>= k = runKureM (\ a -> getChildSecond (mplus mcu) (k a))+ (\ msg -> GetChild (fail msg) mcu)+ kma+ {-# INLINE (>>=) #-}++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> GetChild c u a+ fail msg = GetChild (fail msg) Nothing+ {-# INLINE fail #-}+#endif++instance MonadFail (GetChild c u) where+ fail :: String -> GetChild c u a+ fail msg = GetChild (fail msg) Nothing+ {-# INLINE fail #-}++instance MonadCatch (GetChild c u) where+ catchM :: GetChild c u a -> (String -> GetChild c u a) -> GetChild c u a+ uc@(GetChild kma mcu) `catchM` k = runKureM (\ _ -> uc)+ (\ msg -> getChildSecond (mplus mcu) (k msg))+ kma+ {-# INLINE catchM #-}+++wrapGetChild :: (ReadPath c crumb, Eq crumb) => crumb -> Rewrite c (GetChild c g) g+wrapGetChild cr = do cr' <- lastCrumbT+ rewrite $ \ c a -> GetChild (return a) (if cr == cr' then Just (c, a) else Nothing)+{-# INLINE wrapGetChild #-}++unwrapGetChild :: Rewrite c (GetChild c u) u -> Transform c Maybe u (c,u)+unwrapGetChild = resultT (\ (GetChild _ mcu) -> mcu)+{-# INLINE unwrapGetChild #-}++getChild :: (ReadPath c crumb, Eq crumb, Walker c u) => crumb -> Transform c Maybe u (c, u)+getChild = unwrapGetChild . allR . wrapGetChild+{-# INLINE getChild #-}++-------------------------------------------------------------------------------++type SetChild = KureM++wrapSetChild :: (ReadPath c crumb, Eq crumb) => crumb -> u -> Rewrite c SetChild u+wrapSetChild cr u = do cr' <- lastCrumbT+ if cr == cr' then return u else idR+{-# INLINE wrapSetChild #-}++unwrapSetChild :: MonadFail m => Rewrite c SetChild u -> Rewrite c m u+unwrapSetChild = resultT liftKureM+{-# INLINE unwrapSetChild #-}++setChild :: (ReadPath c crumb, Eq crumb, Walker c u, MonadFail m) => crumb -> u -> Rewrite c m u+setChild cr = unwrapSetChild . allR . wrapSetChild cr+{-# INLINE setChild #-}++-------------------------------------------------------------------------------++childL_default :: forall c crumb m u. (ReadPath c crumb, Eq crumb) => (Walker c u, MonadCatch m) => crumb -> Lens c m u u+childL_default cr = lens $ prefixFailMsg "childL failed: " $+ do cu <- getter+ k <- setter+ return (cu, k)+ where+ getter :: Transform c m u (c,u)+ getter = resultT (projectWithFailMsgM "there is no child matching the crumb.") (getChild cr)+ {-# INLINE getter #-}++ setter :: Transform c m u (u -> m u)+ setter = transform $ \ c a -> return (\ b -> applyR (setChild cr b) c a)+ {-# INLINE setter #-}+{-# INLINE childL_default #-}++-------------------------------------------------------------------------------
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,2 @@+> import Distribution.Simple+> main = defaultMain
+ examples/Examples.hs view
@@ -0,0 +1,21 @@+module Examples where++import Fib.Examples as F+import Lam.Examples as L+import Expr.Examples as E++---------------------------------------------------------------++main :: IO ()+main = do ppTest "Fib" F.checkTests+ ppTest "Lam" L.checkTests+ ppTest "Expr" E.checkTests++ppTest :: String -> Bool -> IO ()+ppTest n b = putStrLn (n ++ " examples: tests " ++ ppBool b)++ppBool :: Bool -> String+ppBool True = "passed"+ppBool False = "failed"++---------------------------------------------------------------
+ examples/Expr/AST.hs view
@@ -0,0 +1,26 @@+{-# Language InstanceSigs #-}+module Expr.AST where++-----------------------------------------------------------------++type Name = String++data Cmd = Seq Cmd Cmd | Assign Name Expr+ deriving Eq++data Expr = Var Name | Lit Int | Add Expr Expr | ESeq Cmd Expr+ deriving Eq++instance Show Cmd where+ show :: Cmd -> String+ show (Seq c1 c2) = show c1 ++ " ; " ++ show c2+ show (Assign n e) = n ++ " := " ++ show e++instance Show Expr where+ show :: Expr -> String+ show (Var n) = n+ show (Lit n) = show n+ show (Add e1 e2) = "(" ++ show e1 ++ " + " ++ show e2 ++ ")"+ show (ESeq c e) = "\n( let " ++ show c ++ "\n in " ++ show e ++ ")\n"++-----------------------------------------------------------------
+ examples/Expr/Context.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses #-}++module Expr.Context where++import Data.Monoid (mempty)++import Language.KURE+import Language.KURE.ExtendableContext++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Expr.AST++---------------------------------------------------------------------------++data Context = Context (AbsolutePath Int) [(Name,Expr)] -- A list of bindings.+ -- We assume no shadowing in the language.++instance ExtendPath Context Int where+ (@@) :: Context -> Int -> Context+ (Context p defs) @@ n = Context (p @@ n) defs++instance ReadPath Context Int where+ absPath :: Context -> AbsolutePath Int+ absPath (Context p _) = p++class AddDef c where+ addDef :: Name -> Expr -> c -> c++updateContextCmd :: AddDef c => Cmd -> c -> c+updateContextCmd (Seq c1 c2) = updateContextCmd c2 . updateContextCmd c1+updateContextCmd (Assign v e) = (addDef v e)++instance AddDef (SnocPath crumb) where+ addDef :: Name -> Expr -> SnocPath crumb -> SnocPath crumb+ addDef _ _ = id++instance AddDef Context where+ addDef :: Name -> Expr -> Context -> Context+ addDef v e (Context p defs) = Context p ((v,e):defs)++instance (AddDef c, AddDef e) => AddDef (ExtendContext c e) where+ addDef :: Name -> Expr -> ExtendContext c e -> ExtendContext c e+ addDef v e c = c+ { baseContext = addDef v e (baseContext c)+ , extraContext = addDef v e (extraContext c)+ }++initialContext :: Context+initialContext = Context mempty []++lookupDef :: MonadFail m => Name -> Context -> m Expr+lookupDef v (Context _ defs) = maybe (fail $ v ++ " not found in context") return (lookup v defs)++---------------------------------------------------------------------------
+ examples/Expr/Examples.hs view
@@ -0,0 +1,187 @@+module Expr.Examples where++import Data.Monoid (mempty)+import Control.Arrow (arr)++import Language.KURE+import Language.KURE.Pathfinder++import Expr.AST+import Expr.Context+import Expr.Kure++-----------------------------------------------------------------++type RewriteE a = Rewrite Context KureM a+type TransformE a b = Transform Context KureM a b++-----------------------------------------------------------------++applyE :: TransformE a b -> a -> Either String b+applyE t = runKureM Right Left . applyT t initialContext++-----------------------------------------------------------------++inlineR :: RewriteE Expr+inlineR = withPatFailMsg "only variables can be inlined." $+ do (c, Var v) <- exposeT+ constT (lookupDef v c)++inlineGR :: RewriteE Universe+inlineGR = promoteR inlineR++isAssign :: Universe -> Bool+isAssign (GCmd Assign{}) = True+isAssign _ = False++isESeq :: Universe -> Bool+isESeq (GExpr ESeq{}) = True+isESeq _ = False++-----------------------------------------------------------------++cmd1 :: Cmd+cmd1 = Seq (Assign "m" (Lit 7))+ (Assign "n" (Add (Lit 1) (Lit 2)))++expr1 :: Expr+expr1 = ESeq cmd1+ (Add (Var "m")+ (Var "n")+ )++result1a :: Expr+result1a = ESeq cmd1+ (Add (Lit 7)+ (Add (Lit 1) (Lit 2))+ )++result1b :: Expr+result1b = ESeq cmd1+ (Add (Lit 7)+ (Var "n")+ )++test1a :: Bool+test1a = applyE (extractR (anytdR inlineGR)) expr1 == Right result1a++test1b :: Bool+test1b = applyE (extractR (onebuR inlineGR)) expr1 == Right result1b++test1c :: Bool+test1c = applyE (extractR (onetdR inlineGR)) expr1 == Right result1b++-----------------------------------------------------------------++expr2 :: Expr+expr2 = ESeq cmd1+ (Add (Var "m")+ (Var "x")+ )++result2a :: Expr+result2a = ESeq (Seq (Assign "m" (Lit 7))+ (Assign "n" (Add (Lit 1) (Lit 2)))+ )+ (Add (Lit 7)+ (Var "x")+ )++test2a :: Bool+test2a = applyE (extractR (anytdR inlineGR)) expr2 == Right result2a++----------------------------------------------------------------++assignMpath :: LocalPath Int+assignMpath = mempty @@ 0 @@ 0++assignNpath :: LocalPath Int+assignNpath = mempty @@ 0 @@ 1++test2b :: Bool+test2b = applyE (extractT $ pathsToT $ arr isAssign) expr2 == Right [assignMpath,assignNpath]++test2c :: Bool+test2c = applyE (extractT $ onePathToT $ arr isAssign) expr2 == Right assignMpath++test2d :: Bool+test2d = applyE (extractT $ oneNonEmptyPathToT $ arr isAssign) expr2 == Right assignMpath++test2e :: Bool+test2e = applyE (extractT $ onePathToT $ arr isESeq) expr2 == Right mempty++test2f :: Bool+test2f = applyE (extractT $ oneNonEmptyPathToT $ arr isESeq) expr2 == Left "No matching nodes found."++-----------------------------------------------------------------++expr3 :: Expr+expr3 = ESeq (Assign "m" (Lit 7)+ )+ (Add (Var "y")+ (Var "x")+ )++test3a :: Bool+test3a = applyE (extractR (anytdR inlineGR)) expr3 == Left "anytdR failed"++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 Universe+incrLitGR = promoteR incrLitR++isExpr :: TransformE Universe 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+ , test2a, test2b, test2c, test2d, test2e, test2f+ , test3a, test3b, test3c+ , test4a, test4b, test4c+ ]++-----------------------------------------------------------------
+ examples/Expr/Kure.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs, LambdaCase, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}++module Expr.Kure where++import Control.Monad++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Language.KURE++import Expr.AST+import Expr.Context++---------------------------------------------------------------------------++data Universe = GExpr Expr+ | GCmd Cmd++---------------------------------------------------------------------------++instance Injection Expr Universe where+ inject = GExpr++ project (GExpr e) = Just e+ project _ = Nothing++instance Injection Cmd Universe where+ inject = GCmd++ project (GCmd c) = Just c+ project _ = Nothing++---------------------------------------------------------------------------++instance (ExtendPath c Int, AddDef c) => Walker c Universe where+ allR :: MonadCatch m => Rewrite c m Universe -> Rewrite c m Universe+ allR r = prefixFailMsg "allR failed: " $+ rewrite $ \ c -> \case+ GExpr e -> inject <$> applyR allRexpr c e+ GCmd cm -> inject <$> applyR allRcmd c cm+ where+ allRexpr = readerT $ \case+ Add _ _ -> addAllR (extractR r) (extractR r)+ ESeq _ _ -> eseqAllR (extractR r) (extractR r)+ _ -> idR++ allRcmd = readerT $ \case+ Seq _ _ -> seqAllR (extractR r) (extractR r)+ Assign _ _ -> assignR (extractR r)++---------------------------------------------------------------------------++seqT :: (ExtendPath c Int, AddDef c, MonadFail m) => Transform c m Cmd a1 -> Transform c m Cmd a2 -> (a1 -> a2 -> b) -> Transform c m Cmd b+seqT t1 t2 f = transform $ \ c -> \case+ Seq cm1 cm2 -> f <$> applyT t1 (c @@ 0) cm1 <*> applyT t2 (updateContextCmd cm1 c @@ 1) cm2+ _ -> fail "not a Seq"++seqAllR :: (ExtendPath c Int, AddDef c, MonadFail m) => Rewrite c m Cmd -> Rewrite c m Cmd -> Rewrite c m Cmd+seqAllR r1 r2 = seqT r1 r2 Seq++seqAnyR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Cmd -> Rewrite c m Cmd+seqAnyR r1 r2 = unwrapAnyR $ seqAllR (wrapAnyR r1) (wrapAnyR r2)++seqOneR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Cmd -> Rewrite c m Cmd+seqOneR r1 r2 = unwrapOneR $ seqAllR (wrapOneR r1) (wrapOneR r2)++---------------------------------------------------------------------------++assignT :: (ExtendPath c Int, MonadFail m) => Transform c m Expr a -> (Name -> a -> b) -> Transform c m Cmd b+assignT t f = transform $ \ c -> \case+ Assign n e -> f n <$> applyT t (c @@ 0) e+ _ -> fail "not an Assign"++assignR :: (ExtendPath c Int, MonadFail m) => Rewrite c m Expr -> Rewrite c m Cmd+assignR r = assignT r Assign++---------------------------------------------------------------------------++varT :: MonadFail m => (Name -> b) -> Transform c m Expr b+varT f = contextfreeT $ \case+ Var v -> return (f v)+ _ -> fail "not a Var"++---------------------------------------------------------------------------++litT :: MonadFail m => (Int -> b) -> Transform c m Expr b+litT f = contextfreeT $ \case+ Lit v -> return (f v)+ _ -> fail "not a Lit"++---------------------------------------------------------------------------++addT :: (ExtendPath c Int, MonadFail m) => Transform c m Expr a1 -> Transform c m Expr a2 -> (a1 -> a2 -> b) -> Transform c m Expr b+addT t1 t2 f = transform $ \ c -> \case+ Add e1 e2 -> f <$> applyT t1 (c @@ 0) e1 <*> applyT t2 (c @@ 1) e2+ _ -> fail "not an Add"++addAllR :: (ExtendPath c Int, MonadFail m) => Rewrite c m Expr -> Rewrite c m Expr -> Rewrite c m Expr+addAllR r1 r2 = addT r1 r2 Add++addAnyR :: (ExtendPath c Int, MonadCatch m) => Rewrite c m Expr -> Rewrite c m Expr -> Rewrite c m Expr+addAnyR r1 r2 = unwrapAnyR $ addAllR (wrapAnyR r1) (wrapAnyR r2)++addOneR :: (ExtendPath c Int, MonadCatch m) => Rewrite c m Expr -> Rewrite c m Expr -> Rewrite c m Expr+addOneR r1 r2 = unwrapOneR $ addAllR (wrapOneR r1) (wrapOneR r2)++---------------------------------------------------------------------------++eseqT :: (ExtendPath c Int, AddDef c, MonadFail m) => Transform c m Cmd a1 -> Transform c m Expr a2 -> (a1 -> a2 -> b) -> Transform c m Expr b+eseqT t1 t2 f = transform $ \ c -> \case+ ESeq cm e1 -> f <$> applyT t1 (c @@ 0) cm <*> applyT t2 (updateContextCmd cm c @@ 1) e1+ _ -> fail "not an ESeq"++eseqAllR :: (ExtendPath c Int, AddDef c, MonadFail m) => Rewrite c m Cmd -> Rewrite c m Expr -> Rewrite c m Expr+eseqAllR r1 r2 = eseqT r1 r2 ESeq++eseqAnyR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Expr -> Rewrite c m Expr+eseqAnyR r1 r2 = unwrapAnyR $ eseqAllR (wrapAnyR r1) (wrapAnyR r2)++eseqOneR :: (ExtendPath c Int, AddDef c, MonadCatch m) => Rewrite c m Cmd -> Rewrite c m Expr -> Rewrite c m Expr+eseqOneR r1 r2 = unwrapOneR $ eseqAllR (wrapOneR r1) (wrapOneR r2)++---------------------------------------------------------------------------
+ examples/Fib/AST.hs view
@@ -0,0 +1,18 @@+module Fib.AST (Arith (..)) where++data Arith = Lit Int | Add Arith Arith | Sub Arith Arith | Fib Arith deriving Eq++instance Show Arith where+ show (Lit n) = show n+ show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"+ show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"+ show (Fib x) = "(Fib " ++ show x ++ ")"++instance Num Arith where+ (+) = Add+ (-) = Sub+ fromInteger = Lit . fromInteger+ negate x = Sub 0 x+ (*) = error "Multiplication not defined for Arith"+ abs = error "Absolute value not defined for Arith"+ signum = error "Signum not defined for Arith"
+ examples/Fib/Examples.hs view
@@ -0,0 +1,152 @@+module Fib.Examples where++import Data.Monoid (mempty)++import Language.KURE++import Fib.AST+import Fib.Kure++-----------------------------------------------------------------------++-- | For this simple example, the context is just an 'AbsolutePath', and transformations always operates on 'Arith'.+type TransformA b = Transform (AbsolutePath Crumb) KureM Arith b+type RewriteA = TransformA Arith++-----------------------------------------------------------------------++applyFib :: TransformA b -> Arith -> Either String b+applyFib t = runKureM Right Left . applyT t mempty++-----------------------------------------------------------------------++-- | Apply the definition of the fibonacci function once.+-- 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) <- idR+ case n of+ 0 -> return (Lit 0)+ 1 -> return (Lit 1)+ _ -> return (Add (Fib (Sub (Lit n) (Lit 1)))+ (Fib (Sub (Lit n) (Lit 2)))+ )++-- | Compute the addition of two literals.+addLitR :: RewriteA+addLitR = withPatFailMsg "addLitR failed" $+ 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) <- idR+ return (Lit (m - n))++-----------------------------------------------------------------------++arithR :: RewriteA+arithR = setFailMsg "arithR failed" $+ addLitR >+> subLitR++anyAddR :: RewriteA+anyAddR = anybuR addLitR++anySubR :: RewriteA+anySubR = anybuR subLitR++anyArithR :: RewriteA+anyArithR = anybuR arithR++allArithR :: RewriteA+allArithR = allbuR arithR++evalR :: RewriteA+evalR = innermostR (arithR >+> fibLitR)++-----------------------------------------------------------------------++expr1 :: Arith+expr1 = (3 + 7) - (4 + 1)++expr2 :: Arith+expr2 = Fib 8++expr3 :: Arith+expr3 = 100 - Fib (3 + 7)++test1a :: Bool+test1a = applyFib (allR addLitR) expr1+ ==+ Right (10 - 5)++test1b :: Bool+test1b = applyFib (alltdR addLitR) expr1+ ==+ Left "alltdR failed: addLitR failed"++test1c :: Bool+test1c = applyFib anyAddR expr1+ ==+ Right (10 - 5)++test1d :: Bool+test1d = applyFib anySubR expr1+ ==+ Left "anybuR failed"++test1e :: Bool+test1e = applyFib anyArithR expr1+ ==+ Right 5++test1f :: Bool+test1f = applyFib evalR expr1+ ==+ Right 5++test2a :: Bool+test2a = applyFib fibLitR expr2+ ==+ Right ((Fib (8 - 1)) + (Fib (8 - 2)))++test2b :: Bool+test2b = applyFib (anytdR fibLitR) expr2+ ==+ Right ((Fib (8 - 1)) + (Fib (8 - 2)))++test2c :: Bool+test2c = applyFib evalR expr2+ ==+ Right 21++test3a :: Bool+test3a = applyFib anyArithR expr3+ ==+ Right (100 - (Fib 10))++test3b :: Bool+test3b = applyFib (anyArithR >+> anyR fibLitR) expr3+ ==+ Right (100 - ((Fib (10 - 1)) + (Fib (10 - 2))))++test3c :: Bool+test3c = applyFib evalR expr3+ ==+ Right 45++test3d :: Bool+test3d = applyFib allArithR expr3+ ==+ Left "allbuR failed: allR failed: arithR failed"++-----------------------------------------------------------------------++checkTests :: Bool+checkTests = and [ test1a, test1b, test1c, test1d, test1e, test1f+ , test2a, test2b, test2c+ , test3a, test3b, test3c, test3d+ ]++-----------------------------------------------------------------------
+ examples/Fib/Kure.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE InstanceSigs, LambdaCase, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++module Fib.Kure (Crumb(..)) where++import Prelude hiding (Left, Right)++import Language.KURE++import Fib.AST++import Control.Monad(liftM, ap)++--------------------------------------------------------------------------------------++data Crumb = LeftChild | RightChild | OnlyChild deriving (Eq,Show)++instance ExtendPath c Crumb => Walker c Arith where+ allR :: MonadCatch m => Rewrite c m Arith -> Rewrite c m Arith+ allR r = prefixFailMsg "allR failed: " $+ rewrite $ \ c -> \case+ Lit n -> Lit <$> return n+ Add e0 e1 -> Add <$> applyR r (c @@ LeftChild) e0 <*> applyR r (c @@ RightChild) e1+ Sub e0 e1 -> Sub <$> applyR r (c @@ LeftChild) e0 <*> applyR r (c @@ RightChild) e1+ Fib e0 -> Fib <$> applyR r (c @@ OnlyChild) e0++--------------------------------------------------------------------------------------
+ examples/Lam/AST.hs view
@@ -0,0 +1,17 @@+module Lam.AST (Name, Exp(..)) where++-------------------------------------------------------------------------------++type Name = String++data Exp = Lam Name Exp+ | App Exp Exp+ | Var Name+ deriving Eq++instance Show Exp where+ show (Var v) = v+ show (App x y) = "(" ++ show x ++ " " ++ show y ++ ")"+ show (Lam n x) = "(\\" ++ n ++ ". " ++ show x ++ ")"++-------------------------------------------------------------------------------
+ examples/Lam/Context.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE InstanceSigs, MultiParamTypeClasses #-}+module Lam.Context where++import Data.Monoid (mempty)++import Language.KURE++import Lam.AST (Name)++-------------------------------------------------------------------------------++data Crumb = Lam_Body+ | Lam_Name+ | App_Fun+ | App_Arg+ deriving (Eq, Show)++-- The context+data LamC = LamC (AbsolutePath Crumb) [Name] -- bound variable names++class AddBoundVar c where+ addBoundVar :: Name -> c -> c++instance AddBoundVar LamC where+ addBoundVar :: Name -> LamC -> LamC+ addBoundVar v (LamC p vs) = LamC p (v:vs)++instance ExtendPath LamC Crumb where+ (@@) :: LamC -> Crumb -> LamC+ (LamC p vs) @@ cr = LamC (p @@ cr) vs++instance ReadPath LamC Crumb where+ absPath :: LamC -> AbsolutePath Crumb+ absPath (LamC p _) = p++initialLamC :: LamC+initialLamC = LamC mempty []++bindings :: LamC -> [Name]+bindings (LamC _ vs) = vs++boundIn :: Name -> LamC -> Bool+boundIn v c = v `elem` bindings c++freeIn :: Name -> LamC -> Bool+freeIn v c = not (v `boundIn` c)++-------------------------------------------------------------------------------
+ examples/Lam/Examples.hs view
@@ -0,0 +1,240 @@+module Lam.Examples where++import Language.KURE++import Lam.AST+import Lam.Kure+import Lam.Context+import Lam.Monad++import Data.List (nub)++import Control.Category ((>>>))++-------------------------------------------------------------------------------++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 TransformE b = Transform LamC LamM Exp b+type RewriteE = TransformE Exp++-------------------------------------------------------------------------------++applyExp :: TransformE b -> Exp -> Either String b+applyExp t = runLamM . applyT t initialLamC++------------------------------------------------------------------------++freeVarsT :: TransformE [Name]+freeVarsT = fmap nub $ crushbuT $ do (c, Var v) <- exposeT+ guardM (v `freeIn` c)+ return [v]++freeVars :: Exp -> [Name]+freeVars = either error id . applyExp freeVarsT++-- Only works for lambdas, fails for all others+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 -> 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 <- 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 _ _ <- idR+ anyR (substExp v s) -- Rule 6++------------------------------------------------------------------------++beta_reduce :: RewriteE+beta_reduce = withPatFailMsg "Cannot beta-reduce, not app-lambda." $+ do App (Lam v _) e2 <- idR+ pathT [App_Fun,Lam_Body] (tryR $ substExp v e2)++eta_expand :: RewriteE+eta_expand = rewrite $ \ c f -> do v <- freshName (bindings c)+ return $ Lam v (App f (Var v))++eta_reduce :: RewriteE+eta_reduce = withPatFailMsg "Cannot eta-reduce, not lambda-app-var." $+ 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 :: 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 :: RewriteE+applicative_order_eval = innermostR beta_reduce++------------------------------------------------------------------------++type LamTest = (RewriteE, String, Exp, Maybe Exp)++runLamTest :: LamTest -> (Bool, String)+runLamTest (r,_,e,me) = case (applyExp r e , me) of+ (Right r1 , Just r2) | r1 == r2 -> (True, show r1)+ (Left msg , Nothing) -> (True, msg)+ (Left msg , Just _) -> (False, msg)+ (Right r1 , _ ) -> (False, show r1)++ppLamTest :: LamTest -> IO ()+ppLamTest t@(_,n,e,me) = do putStrLn $ "Rewrite: " ++ n+ putStrLn $ "Initial expression: " ++ show e+ putStrLn $ "Expected outcome: " ++ maybe "failure" show me+ let (b,msg) = runLamTest t+ putStrLn $ "Actual outcome: " ++ msg+ putStrLn (if b then "TEST PASSED" else "TEST FAILED")+ putStrLn ""++------------------------------------------------------------------------++x :: Exp+x = Var "x"++y :: Exp+y = Var "y"++z :: Exp+z = Var "z"++g :: Exp+g = Var "g"++h :: Exp+h = Var "h"++gx :: Exp+gx = App g x++gy :: Exp+gy = App g y++gz :: Exp+gz = App g z++hz :: Exp+hz = App h z++g0 :: Exp+g0 = App g (Var "0")++xx :: Exp+xx = App x x++yy :: Exp+yy = App y y++xz :: Exp+xz = App x z++fix :: Exp+fix = Lam "g" (App body body)+ where+ body = Lam "x" (App g xx)++------------------------------------------------------------------------++test_eta_exp1 :: LamTest+test_eta_exp1 = (eta_expand, "eta-expand", g, Just (Lam "0" g0))++test_eta_exp2 :: LamTest+test_eta_exp2 = (eta_expand, "eta-expand", App (Lam "g" gx) (Lam "y" yy), Just (Lam "0" (App (App (Lam "g" gx) (Lam "y" yy)) (Var "0"))))++test_eta_red1 :: LamTest+test_eta_red1 = (eta_reduce, "eta-reduce", Lam "x" gx , Just g)++test_eta_red2 :: LamTest+test_eta_red2 = (eta_reduce, "eta-reduce", Lam "x" gy, Nothing)++test_eta_red3 :: LamTest+test_eta_red3 = (eta_reduce, "eta-reduce", g, Nothing)++test_beta_red1 :: LamTest+test_beta_red1 = (beta_reduce, "beta-reduce", App (Lam "x" gx) z, Just gz)++test_beta_red2 :: LamTest+test_beta_red2 = (beta_reduce, "beta-reduce", App (Lam "x" gy) z, Just gy)++test_beta_red3 :: LamTest+test_beta_red3 = (beta_reduce, "beta-reduce", App x (Lam "y" gy), Nothing)++test_beta_reds1 :: LamTest+test_beta_reds1 = (anybuR beta_reduce, "any bottom-up beta-reduce", gx, Nothing)++test_beta_reds2 :: LamTest+test_beta_reds2 = (anybuR beta_reduce, "any bottom-up beta-reduce", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just (App (Lam "h" hz) x))++test_beta_reds3a :: LamTest+test_beta_reds3a = (beta_reduce, "beta-reduce", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just (App (Lam "h" (App h (App (Lam "y" y) z))) x))++test_beta_reds3 :: LamTest+test_beta_reds3 = (normal_order_eval, "normal order evaluation", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just xz)++test_beta_reds4 :: LamTest+test_beta_reds4 = (applicative_order_eval, "applicative order evaluation", App (Lam "g" gx) (Lam "h" (App h (App (Lam "y" y) z)))+ , Just xz)++test_fix1 :: LamTest+test_fix1 = (normal_order_eval, "normal order evaluation", App fix (Lam "_" x), Just x)++diverge :: Either String Exp+diverge = applyExp applicative_order_eval (App fix (Lam "_" x))++test_fix2 :: LamTest+test_fix2 = (anybuR (andR $ replicate 3 $ anybuR beta_reduce), "applicative order evaluation - 3 step cap", App fix (Lam "_" x)+ , Just (App (Lam "g" (App g (App g (App g (App g (App g (App g (App (Lam "x" (App g xx)) (Lam "x" (App g xx))))))))))+ (Lam "_" x))+ )++all_tests :: [LamTest]+all_tests = [ test_eta_exp1+ , test_eta_exp2+ , test_eta_red1+ , test_eta_red2+ , test_eta_red3+ , test_beta_red1+ , test_beta_red2+ , test_beta_red3+ , test_beta_reds1+ , test_beta_reds2+ , test_beta_reds3+ , test_beta_reds4+ , test_fix1+ , test_fix2+ ]++checkTests :: Bool+checkTests = all (fst . runLamTest) all_tests++printTests :: IO ()+printTests = mapM_ ppLamTest all_tests++------------------------------------------------------------------------
+ examples/Lam/Kure.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs, LambdaCase, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}++module Lam.Kure where++import Control.Monad++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++import Language.KURE++import Lam.AST+import Lam.Context++-------------------------------------------------------------------------------++instance (ExtendPath c Crumb, AddBoundVar c) => Walker c Exp where+ allR :: MonadCatch m => Rewrite c m Exp -> Rewrite c m Exp+ allR r = prefixFailMsg "allR failed: " $+ readerT $ \case+ App _ _ -> appAllR r r+ Lam _ _ -> lamR r+ _ -> idR++-------------------------------------------------------------------------------++-- | Congruence combinators.+-- Using these ensures that the context is updated consistantly.++varT :: MonadFail m => (Name -> b) -> Transform c m Exp b+varT f = contextfreeT $ \case+ Var n -> return (f n)+ _ -> fail "no match for Var"++-------------------------------------------------------------------------------++lamT :: (ExtendPath c Crumb, AddBoundVar c, MonadFail m) => Transform c m Exp a -> (Name -> a -> b) -> Transform c m Exp b+lamT t f = transform $ \ c -> \case+ Lam v e -> f v <$> applyT t (addBoundVar v c @@ Lam_Body) e+ _ -> fail "no match for Lam"++lamR :: (ExtendPath c Crumb, AddBoundVar c, MonadFail m) => Rewrite c m Exp -> Rewrite c m Exp+lamR r = lamT r Lam++-------------------------------------------------------------------------------++appT :: (ExtendPath c Crumb, MonadFail m) => Transform c m Exp a1 -> Transform c m Exp a2 -> (a1 -> a2 -> b) -> Transform c m Exp b+appT t1 t2 f = transform $ \ c -> \case+ App e1 e2 -> f <$> applyT t1 (c @@ App_Fun) e1 <*> applyT t2 (c @@ App_Arg) e2+ _ -> fail "no match for App"++appAllR :: (ExtendPath c Crumb, MonadFail m) => Rewrite c m Exp -> Rewrite c m Exp -> Rewrite c m Exp+appAllR r1 r2 = appT r1 r2 App++appAnyR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Exp -> Rewrite c m Exp -> Rewrite c m Exp+appAnyR r1 r2 = unwrapAnyR $ appAllR (wrapAnyR r1) (wrapAnyR r2)++appOneR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Exp -> Rewrite c m Exp -> Rewrite c m Exp+appOneR r1 r2 = unwrapOneR $ appAllR (wrapOneR r1) (wrapOneR r2)++-------------------------------------------------------------------------------
+ examples/Lam/Monad.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+{-# Language InstanceSigs #-}++module Lam.Monad where++import Language.KURE++import Control.Applicative+import Control.Monad++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif++-------------------------------------------------------------------------------++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 a+ return a = LamM (\n -> (n,Right a))++ (>>=) :: LamM a -> (a -> LamM b) -> LamM b+ (LamM f) >>= gg = LamM $ \ n -> case f n of+ (n', Left msg) -> (n', Left msg)+ (n', Right a) -> lamM (gg a) n'++#if !MIN_VERSION_base(4,13,0)+ fail :: String -> LamM a+ fail msg = LamM (\ n -> (n, Left msg))+#endif++instance MonadFail LamM where+ fail :: String -> LamM a+ fail msg = LamM (\ n -> (n, Left msg))++instance MonadCatch LamM where+ catchM :: LamM a -> (String -> LamM a) -> LamM a+ (LamM st) `catchM` f = LamM $ \ n -> case st n of+ (n', Left msg) -> lamM (f msg) n'+ (n', Right a) -> (n', Right a)++instance Functor LamM where+ fmap :: (a -> b) -> LamM a -> LamM b+ fmap = liftM++instance Applicative LamM where+ pure :: a -> LamM a+ pure = return++ (<*>) :: LamM (a -> b) -> LamM a -> LamM b+ (<*>) = ap++-------------------------------------------------------------------------------
kure.cabal view
@@ -1,31 +1,69 @@ Name: kure-Version: 0.3.1+Version: 2.18.6 Synopsis: Combinators for Strategic Programming-Description: KURE is a DSL for building rewriting DSLs.- KURE shares combinator names and concepts with Stratego, but unlike Stratego, KURE is strongly typed.- KURE is similar to Strafunski, but has a lightweight generic traversal mechanism using type families- rather than SYB,- and the KURE combinators are parameterized to provide the ability to have context sensitive rewrites.+Description: The Kansas University Rewrite Engine (KURE) is a domain-specific language for strategic rewriting.+ KURE was inspired by Stratego and StrategyLib, and has similarities with Scrap Your Boilerplate and Uniplate.+ .+ The basic transformation functionality can be found in "Language.KURE.Transform",+ 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 larger examples, see the HERMIT or HTML-KURE packages.+ .+ You can read about KURE in the following article:+ .+ The Kansas University Rewrite Engine: A Haskell-Embedded Strategic Programming Language with Custom Closed Universes. Neil Sculthorpe, Nicolas Frisby and Andy Gill. Journal of Functional Programming. Cambridge University Press, 24(4), pages 434-473, 2014.+ <https://dx.doi.org/10.1017/S0956796814000185> Category: Language License: BSD3 License-file: LICENSE-Author: Andy Gill-Maintainer: Andy Gill <andygill@ku.edu>-Copyright: (c) 2006-2009 Andy Gill-Homepage: http://ittc.ku.edu/~andygill/kure.php-Stability: alpha-build-type: Simple-Cabal-Version: >= 1.6+Author: Neil Sculthorpe and Andy Gill+Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>+Copyright: (c) 2006--2021 The University of Kansas+Homepage: https://ku-fpg.github.io/software/kure/+Stability: beta+build-type: Simple+Cabal-Version: 1.16+Extra-Source-Files:+ CHANGELOG.md+ examples/Examples.hs+ examples/Fib/AST.hs+ examples/Fib/Kure.hs+ examples/Fib/Examples.hs+ examples/Lam/AST.hs+ examples/Lam/Context.hs+ examples/Lam/Monad.hs+ examples/Lam/Kure.hs+ examples/Lam/Examples.hs+ examples/Expr/AST.hs+ examples/Expr/Context.hs+ examples/Expr/Kure.hs+ examples/Expr/Examples.hs Library- Build-Depends: base+ Build-Depends:+ base >= 4.8 && < 5,+ dlist >= 0.6 && < 1,+ transformers >= 0.4.1 && < 1+ default-language: Haskell2010+ Ghc-Options: -Wall Exposed-modules:- Language.KURE,- Language.KURE.RewriteMonad, - Language.KURE.Translate,- Language.KURE.Rewrite,- Language.KURE.Combinators,- Language.KURE.Term- Ghc-Options: -Wall+ Language.KURE+ Language.KURE.BiTransform+ Language.KURE.Combinators+ Language.KURE.Combinators.Arrow+ Language.KURE.Combinators.Monad+ Language.KURE.Combinators.Transform+ Language.KURE.Debug+ Language.KURE.ExtendableContext+ Language.KURE.Injection+ Language.KURE.Lens+ Language.KURE.MonadCatch+ Language.KURE.Path+ Language.KURE.Pathfinder+ Language.KURE.Transform+ Language.KURE.Walker +source-repository head+ type: git+ location: git://github.com/ku-fpg/kure