kure 2.6.22 → 2.8.0
raw patch · 16 files changed
+398/−313 lines, 16 files
Files
- Language/KURE.hs +2/−0
- Language/KURE/Injection.hs +1/−1
- Language/KURE/Path.hs +140/−0
- Language/KURE/Walker.hs +81/−189
- examples/Expr/Context.hs +37/−0
- examples/Expr/Examples.hs +1/−0
- examples/Expr/Kure.hs +10/−34
- examples/Fib/AST.hs +1/−1
- examples/Fib/Examples.hs +5/−3
- examples/Fib/Kure.hs +12/−7
- examples/Lam/AST.hs +1/−1
- examples/Lam/Context.hs +48/−0
- examples/Lam/Examples.hs +6/−33
- examples/Lam/Kure.hs +13/−43
- examples/Lam/Monad.hs +35/−0
- kure.cabal +5/−1
Language/KURE.hs view
@@ -17,10 +17,12 @@ , module Language.KURE.Combinators , module Language.KURE.MonadCatch , module Language.KURE.Injection+ , module Language.KURE.Path ) where import Language.KURE.Combinators import Language.KURE.MonadCatch import Language.KURE.Translate import Language.KURE.Injection+import Language.KURE.Path import Language.KURE.Walker
Language/KURE/Injection.hs view
@@ -72,7 +72,7 @@ projectWithFailMsgM msg = maybe (fail msg) return . project {-# INLINE projectWithFailMsgM #-} --- | Projects a value and lifts it into a 'MonadCatch', with the possibility of failure.+-- | Projects a value and lifts it into a 'Monad', with the possibility of failure. projectM :: (Monad m, Injection a g) => g -> m a projectM = projectWithFailMsgM "projectM failed" {-# INLINE projectM #-}
+ Language/KURE/Path.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}++-- |+-- Module: Language.KURE.Path+-- Copyright: (c) 2012--2013 The University of Kansas+-- License: BSD3+--+-- Maintainer: Neil Sculthorpe <neil@ittc.ku.edu>+-- 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+ , rootPathT+ -- ** Snoc Paths+ , SnocPath(..)+ , snocPathToPath+ , pathToSnocPath+ , lastCrumb+ -- ** Absolute Paths+ , AbsolutePath+ , lastCrumbT+ , ExtendPath(..)+ , ReadPath(..)+ , absPathT+ )+where++import Data.Monoid++import Control.Arrow ((>>^))++import Language.KURE.Translate+import Language.KURE.Combinators.Translate+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 Monoid (SnocPath crumb) where+-- mempty :: SnocPath crumb+ mempty = SnocPath []++-- mappend :: SnocPath crumb -> SnocPath crumb -> SnocPath crumb+ mappend (SnocPath p1) (SnocPath p2) = SnocPath (p2 ++ p1)++-- | 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 #-}++-- | 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 @(\@\@ cr)@ 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 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) => Translate c m a (AbsolutePath crumb)+absPathT = contextT >>^ absPath+{-# INLINE absPathT #-}++-- | Retrieve the 'Path' from the root to the current node.+rootPathT :: (ReadPath c crumb, Monad m) => Translate c m a (Path crumb)+rootPathT = absPathT >>^ snocPathToPath+{-# INLINE rootPathT #-}++-- | Lifted version of 'lastCrumb'.+lastCrumbT :: (ReadPath c crumb, Monad m) => Translate c m a crumb+lastCrumbT = contextonlyT (projectWithFailMsgM (fail "lastCrumbT failed: at the root, no crumbs yet.") . lastCrumb . absPath)+{-# 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/Walker.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts #-} -- | -- Module: Language.KURE.Walker@@ -55,20 +55,11 @@ , oneLargestT -- * Utilitity Translations- , numChildrenT- , hasChildT+ , childrenT , summandIsTypeT -- * Paths- -- ** Absolute Paths- , AbsolutePath- , rootAbsPath- , PathContext(..)- , absPathT- -- ** Relative Paths- , Path- , rootPath- , rootPathT+ -- ** Path-based Translations , pathsToT , onePathToT , oneNonEmptyPathToT@@ -94,7 +85,6 @@ import Data.Maybe (isJust) import Data.Monoid-import Data.List import Data.DList (singleton, toList) import Control.Monad@@ -106,6 +96,7 @@ import Language.KURE.Lens import Language.KURE.Injection import Language.KURE.Combinators+import Language.KURE.Path ------------------------------------------------------------------------------- @@ -144,33 +135,26 @@ {-# INLINE oneR #-} -- | Construct a 'Lens' to the n-th child node.- childL :: MonadCatch m => Int -> Lens c m g g+ childL :: (ReadPath c crumb, Eq crumb, MonadCatch m) => crumb -> Lens c m g g childL = childL_default {-# INLINE childL #-} ------------------------------------------------------------------------------------------ --- | Count the number of children of the current node.-numChildrenT :: (Walker c g, MonadCatch m) => Translate c m g Int-numChildrenT = getSum `liftM` allT (return $ Sum 1)-{-# INLINE numChildrenT #-}---- | Determine if the current node has a child of the specified number.--- Useful when defining custom versions of 'childL'.-hasChildT :: (Walker c g, MonadCatch m) => Int -> Translate c m g Bool-hasChildT n = do c <- numChildrenT- return (n >= 0 && n < c)-{-# INLINE hasChildT #-}+-- | List the children of the current node.+childrenT :: (ReadPath c crumb, Walker c g, MonadCatch m) => Translate c m g [crumb]+childrenT = allT (lastCrumbT >>^ return)+{-# INLINE childrenT #-} ------------------------------------------------------------------------------- -- | Apply a 'Translate' to a specified child.-childT :: (Walker c g, MonadCatch m) => Int -> Translate c m g b -> Translate c m g b+childT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> Translate c m g b -> Translate c m g b childT n = focusT (childL n) {-# INLINE childT #-} -- | Apply a 'Rewrite' to a specified child.-childR :: (Walker c g, MonadCatch m) => Int -> Rewrite c m g -> Rewrite c m g+childR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> Rewrite c m g -> Rewrite c m g childR n = focusR (childL n) {-# INLINE childR #-} @@ -307,97 +291,48 @@ ------------------------------------------------------------------------------- --- | A path from the root.-newtype AbsolutePath = AbsolutePath [Int] deriving Eq--instance Show AbsolutePath where- show (AbsolutePath p) = show (reverse p)- {-# INLINE show #-}---- | The (empty) 'AbsolutePath' to the root.-rootAbsPath :: AbsolutePath-rootAbsPath = AbsolutePath []-{-# INLINE rootAbsPath #-}+-- Apply a local Translate, using only a local path as context.+applySnocPathT :: Translate (SnocPath crumb) m a b -> Translate c m a b+applySnocPathT t = contextfreeT (apply t mempty) --- | Contexts that are instances of 'PathContext' contain the current 'AbsolutePath'.--- Any user-defined combinators (typically 'allR' and congruence combinators) should update the 'AbsolutePath' using '@@'.-class PathContext c where- -- | Retrieve the current absolute path.- absPath :: c -> AbsolutePath-- -- | Extend the current absolute path by one descent.- (@@) :: c -> Int -> c---- | The simplest instance of 'PathContext' is 'AbsolutePath' itself.-instance PathContext AbsolutePath where--- absPath :: AbsolutePath -> AbsolutePath- absPath = id- {-# INLINE absPath #-}---- (@@) :: AbsolutePath -> Int -> AbsolutePath- (AbsolutePath ns) @@ n = AbsolutePath (n:ns)- {-# INLINE (@@) #-}---- | Lifted version of 'absPath'.-absPathT :: (PathContext c, Monad m) => Translate c m a AbsolutePath-absPathT = absPath `liftM` contextT-{-# INLINE absPathT #-}------------------------------------------------------------------------------------- | A path is a route to descend the tree from an arbitrary node.-type Path = [Int]---- | Retrieve the 'Path' from the root to the current node.-rootPath :: PathContext c => c -> Path-rootPath c = let AbsolutePath p = absPath c- in reverse p-{-# INLINE rootPath #-}---- | Lifted version of 'rootPath'.-rootPathT :: (PathContext c, Monad m) => Translate c m a Path-rootPathT = rootPath `liftM` contextT-{-# INLINE rootPathT #-}---- Provided the first 'AbsolutePath' is a prefix of the second 'AbsolutePath',--- computes the 'Path' from the end of the first to the end of the second.-rmPathPrefix :: AbsolutePath -> AbsolutePath -> Maybe Path-rmPathPrefix (AbsolutePath p1) (AbsolutePath p2) = do guard (p1 `isSuffixOf` p2)- return $ drop (length p1) (reverse p2)-{-# INLINE rmPathPrefix #-}---- Construct a 'Path' from the current node to the end of the given 'AbsolutePath', provided that 'AbsolutePath' passes through the current node.-abs2pathT :: (PathContext c, Monad m) => AbsolutePath -> Translate c m a Path-abs2pathT there = do here <- absPathT- maybe (fail "Absolute path does not pass through current node.") return (rmPathPrefix here there)-{-# INLINE abs2pathT #-}- -- | Find the 'Path's to every node that satisfies the predicate.-pathsToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path]-pathsToT q = collectT (acceptR q >>> absPathT) >>= mapM abs2pathT+pathsToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path crumb]+pathsToT q = applySnocPathT pathsToT' >>^ map snocPathToPath+ where+ pathsToT' :: Translate (SnocPath crumb) m g [SnocPath crumb]+ pathsToT' = collectT (acceptR q >>> contextT)+ {-# INLINE pathsToT' #-} {-# INLINE pathsToT #-} +-- | Find the 'Path's to every node that satisfies the predicate, ignoring nodes below successes.+prunePathsToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path crumb]+prunePathsToT q = applySnocPathT prunePathsToT' >>^ map snocPathToPath+ where+ prunePathsToT' :: Translate (SnocPath crumb) m g [SnocPath crumb]+ prunePathsToT' = collectPruneT (acceptR q >>> contextT)+ {-# INLINE prunePathsToT' #-}+{-# INLINE prunePathsToT #-}++ -- | Find the 'Path' to the first node that satisfies the predicate (in a pre-order traversal).-onePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path-onePathToT q = setFailMsg "No matching nodes found." $- onetdT (acceptR q >>> absPathT) >>= abs2pathT+onePathToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)+onePathToT q = applySnocPathT onePathToT' >>^ snocPathToPath+ where+ onePathToT' :: (Walker (SnocPath crumb) g, MonadCatch m) => Translate (SnocPath crumb) m g (SnocPath crumb)+ onePathToT' = setFailMsg "No matching nodes found." $+ onetdT (acceptR q >>> contextT)+ {-# INLINE onePathToT' #-} {-# INLINE onePathToT #-} -- | Find the 'Path' to the first descendent node that satisfies the predicate (in a pre-order traversal).-oneNonEmptyPathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path-oneNonEmptyPathToT q = setFailMsg "No matching nodes found." $- do start <- absPathT- onetdT (acceptR q >>> absPathT >>> acceptR (/= start)) >>= abs2pathT+oneNonEmptyPathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)+oneNonEmptyPathToT q = applySnocPathT $ oneT (lastCrumbT &&& onePathToT q >>^ uncurry (:)) {-# INLINE oneNonEmptyPathToT #-} --- | Find the 'Path's to every node that satisfies the predicate, ignoring nodes below successes.-prunePathsToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path]-prunePathsToT q = collectPruneT (acceptR q >>> absPathT) >>= mapM abs2pathT-{-# INLINE prunePathsToT #-} -- local function used by uniquePathToT and uniquePrunePathToT-requireUniquePath :: Monad m => Translate c m [Path] Path+requireUniquePath :: Monad m => Translate c m [Path crumb] (Path crumb) requireUniquePath = contextfreeT $ \ ps -> case ps of [] -> fail "No matching nodes found." [p] -> return p@@ -405,12 +340,12 @@ {-# INLINE requireUniquePath #-} -- | Find the 'Path' to the node that satisfies the predicate, failing if that does not uniquely identify a node.-uniquePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path+uniquePathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb) uniquePathToT q = pathsToT q >>> requireUniquePath {-# INLINE uniquePathToT #-} -- | Build a 'Path' to the node that satisfies the predicate, failing if that does not uniquely identify a node (ignoring nodes below successes).-uniquePrunePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path+uniquePrunePathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb) uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath {-# INLINE uniquePrunePathToT #-} @@ -421,42 +356,42 @@ {-# INLINE tryL #-} -- | Construct a 'Lens' by following a 'Path'.-pathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g+pathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Lens c m g g pathL = serialise . map childL {-# INLINE pathL #-} -- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed.-exhaustPathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g+exhaustPathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Lens c m g g exhaustPathL = foldr (\ n l -> tryL (childL n >>> l)) id {-# INLINE exhaustPathL #-} -- | Repeat as many iterations of the 'Path' as possible.-repeatPathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g+repeatPathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Lens c m g g repeatPathL p = let go = tryL (pathL p >>> go) in go {-# INLINE repeatPathL #-} -- | Build a 'Lens' from the root to a point specified by an 'AbsolutePath'.-rootL :: (Walker c g, MonadCatch m) => AbsolutePath -> Lens c m g g-rootL = pathL . rootPath+rootL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => AbsolutePath crumb -> Lens c m g g+rootL = pathL . snocPathToPath {-# INLINE rootL #-} ------------------------------------------------------------------------------- -- | Apply a 'Rewrite' at a point specified by a 'Path'.-pathR :: (Walker c g, MonadCatch m) => Path -> Rewrite c m g -> Rewrite c m g+pathR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Rewrite c m g -> Rewrite c m g pathR = focusR . pathL {-# INLINE pathR #-} -- | Apply a 'Translate' at a point specified by a 'Path'.-pathT :: (Walker c g, MonadCatch m) => Path -> Translate c m g b -> Translate c m g b+pathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Translate c m g b -> Translate c m g b pathT = focusT . pathL {-# INLINE pathT #-} ------------------------------------------------------------------------------- -- | Check if it is possible to construct a 'Lens' along this path from the current node.-testPathT :: (Walker c g, MonadCatch m) => Path -> Translate c m g Bool+testPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Translate c m g Bool testPathT = testLensT . pathL {-# INLINE testPathT #-} @@ -604,128 +539,85 @@ ------------------------------------------------------------------------------- -data PInt a = PInt {-# UNPACK #-} !Int a--secondPInt :: (a -> b) -> PInt a -> PInt b-secondPInt f = \ (PInt i a) -> PInt i (f a)-{-# INLINE secondPInt #-}------------------------------------------------------------------------------------- This is hideous.--- Admittedly, part of the problem is using MonadCatch. If allR just used Monad, this (and other things) would be much simpler.+-- 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. -newtype GetChild c g a = GetChild (Int -> PInt (KureM a, Maybe (c,g)))+data GetChild c g a = GetChild (KureM a) (Maybe (c,g)) -unGetChild :: GetChild c g a -> Int -> PInt (KureM a, Maybe (c,g))-unGetChild (GetChild f) = f-{-# INLINE unGetChild #-}+getChildSecond :: (Maybe (c,g) -> Maybe (c,g)) -> GetChild c g a -> GetChild c g a+getChildSecond f (GetChild ka mcg) = GetChild ka (f mcg)+{-# INLINE getChildSecond #-} instance Monad (GetChild c g) where -- return :: a -> GetChild c g a- return a = GetChild $ \ i -> PInt i (return a, Nothing)+ return a = GetChild (return a) Nothing {-# INLINE return #-} -- fail :: String -> GetChild c g a- fail msg = GetChild $ \ i -> PInt i (fail msg, Nothing)+ fail msg = GetChild (fail msg) Nothing {-# INLINE fail #-} -- (>>=) :: GetChild c g a -> (a -> GetChild c g b) -> GetChild c g b- ma >>= f = GetChild $ \ i0 -> let PInt i1 (kma, mcg) = unGetChild ma i0- in runKureM (\ a -> (secondPInt.second) (mplus mcg) $ unGetChild (f a) i1)- (\ msg -> PInt i1 (fail msg, mcg))- kma+ (GetChild kma mcg) >>= k = runKureM (\ a -> getChildSecond (mplus mcg) (k a))+ (\ msg -> GetChild (fail msg) mcg)+ kma {-# INLINE (>>=) #-} instance MonadCatch (GetChild c g) where -- catchM :: GetChild c g a -> (String -> GetChild c g a) -> GetChild c g a- ma `catchM` f = GetChild $ \ i0 -> let p@(PInt i1 (kma, mcg)) = unGetChild ma i0- in runKureM (\ _ -> p)- (\ msg -> (secondPInt.second) (mplus mcg) $ unGetChild (f msg) i1)- kma+ gc@(GetChild kma mcg) `catchM` k = runKureM (\ _ -> gc)+ (\ msg -> getChildSecond (mplus mcg) (k msg))+ kma {-# INLINE catchM #-} -wrapGetChild :: Int -> Rewrite c (GetChild c g) g-wrapGetChild n = rewrite $ \ c a -> GetChild $ \ m -> PInt (m + 1)- (return a, if n == m then Just (c, a) else Nothing)+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 g) g -> Translate c Maybe g (c,g)-unwrapGetChild r = translate $ \ c a -> let PInt _ (_,mcg) = unGetChild (apply r c a) 0- in mcg+unwrapGetChild = resultT (\ (GetChild _ mcg) -> mcg) {-# INLINE unwrapGetChild #-} -getChild :: Walker c g => Int -> Translate c Maybe g (c, g)+getChild :: (ReadPath c crumb, Eq crumb, Walker c g) => crumb -> Translate c Maybe g (c, g) getChild = unwrapGetChild . allR . wrapGetChild {-# INLINE getChild #-} ------------------------------------------------------------------------------- -newtype SetChild a = SetChild (Int -> PInt (KureM a))--unSetChild :: SetChild a -> Int -> PInt (KureM a)-unSetChild (SetChild f) = f-{-# INLINE unSetChild #-}--instance Monad SetChild where--- return :: a -> SetChild c g a- return a = SetChild $ \ i -> PInt i (return a)- {-# INLINE return #-}---- fail :: String -> SetChild c g a- fail msg = SetChild $ \ i -> PInt i (fail msg)- {-# INLINE fail #-}---- (>>=) :: SetChild c g a -> (a -> SetChild c g b) -> SetChild c g b- ma >>= f = SetChild $ \ i0 -> let PInt i1 ka = unSetChild ma i0- in runKureM (\ a -> unSetChild (f a) i1)- (\ msg -> PInt i1 (fail msg))- ka- {-# INLINE (>>=) #-}--instance MonadCatch SetChild where--- catchM :: SetChild c g a -> (String -> SetChild c g a) -> SetChild c g a- ma `catchM` f = SetChild $ \ i0 -> let PInt i1 ka = unSetChild ma i0- in runKureM (\ _ -> PInt i1 ka)- (\ msg -> unSetChild (f msg) i1)- ka- {-# INLINE catchM #-}-+type SetChild = KureM -wrapSetChild :: Int -> g -> Rewrite c SetChild g-wrapSetChild n g = contextfreeT $ \ a -> SetChild $ \ m -> PInt (m + 1)- (return $ if n == m then g else a)+wrapSetChild :: (ReadPath c crumb, Eq crumb) => crumb -> g -> Rewrite c SetChild g+wrapSetChild cr g = do cr' <- lastCrumbT+ if cr == cr' then return g else idR {-# INLINE wrapSetChild #-} unwrapSetChild :: Monad m => Rewrite c SetChild g -> Rewrite c m g-unwrapSetChild r = rewrite $ \ c a -> let PInt _ ka = unSetChild (apply r c a) 0- in runKureM return fail ka+unwrapSetChild = resultT (runKureM return fail) {-# INLINE unwrapSetChild #-} -setChild :: (Walker c g, Monad m) => Int -> g -> Rewrite c m g-setChild n = unwrapSetChild . allR . wrapSetChild n+setChild :: (ReadPath c crumb, Eq crumb, Walker c g, Monad m) => crumb -> g -> Rewrite c m g+setChild cr = unwrapSetChild . allR . wrapSetChild cr {-# INLINE setChild #-} ------------------------------------------------------------------------------- -childL_default :: forall c m g. (Walker c g, MonadCatch m) => Int -> Lens c m g g-childL_default n = lens $ do cg <- getter- k <- setter- return (cg, k)+childL_default :: forall c crumb m g. (ReadPath c crumb, Eq crumb) => (Walker c g, MonadCatch m) => crumb -> Lens c m g g+childL_default cr = lens $ do cg <- getter+ k <- setter+ return (cg, k) where getter :: Translate c m g (c,g)- getter = translate $ \ c a -> maybe (fail $ "there is no child number " ++ show n) return (apply (getChild n) c a)+ getter = resultT (projectWithFailMsgM "there is no child matching the crumb.") (getChild cr) {-# INLINE getter #-} setter :: Translate c m g (g -> m g)- setter = translate $ \ c a -> return (\ b -> apply (setChild n b) c a)+ setter = translate $ \ c a -> return (\ b -> apply (setChild cr b) c a) {-# INLINE setter #-}- {-# INLINE childL_default #-} -------------------------------------------------------------------------------
+ examples/Expr/Context.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Expr.Context where++import Data.Monoid (mempty)++import Language.KURE++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+ absPath (Context p _) = p++addDef :: Name -> Expr -> Context -> Context+addDef v e (Context p defs) = Context p ((v,e):defs)++updateContextCmd :: Cmd -> Context -> Context+updateContextCmd (Seq c1 c2) = updateContextCmd c2 . updateContextCmd c1+updateContextCmd (Assign v e) = (addDef v e)++initialContext :: Context+initialContext = Context mempty []++lookupDef :: Monad 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
@@ -3,6 +3,7 @@ import Language.KURE import Expr.AST+import Expr.Context import Expr.Kure -----------------------------------------------------------------
examples/Expr/Kure.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} module Expr.Kure where @@ -7,31 +7,7 @@ import Language.KURE import Expr.AST-------------------------------------------------------------------------------data Context = Context AbsolutePath [(Name,Expr)] -- A list of bindings.- -- We assume no shadowing in the language.--instance PathContext Context where--- absPath :: Context -> AbsolutePath- absPath (Context p _) = p---- (@@) :: Context -> Int -> Context- (Context p defs) @@ n = Context (p @@ n) defs--addDef :: Name -> Expr -> Context -> Context-addDef v e (Context p defs) = Context p ((v,e):defs)--updateContextCmd :: Cmd -> Context -> Context-updateContextCmd (Seq c1 c2) = updateContextCmd c2 . updateContextCmd c1-updateContextCmd (Assign v e) = (addDef v e)--initialContext :: Context-initialContext = Context rootAbsPath []--lookupDef :: Monad m => Name -> Context -> m Expr-lookupDef v (Context _ defs) = maybe (fail $ v ++ " not found in context") return (lookup v defs)+import Expr.Context --------------------------------------------------------------------------- @@ -88,42 +64,42 @@ --------------------------------------------------------------------------- -assignT :: Monad m => Translate Context m Expr a -> (Name -> a -> b) -> Translate Context m Cmd b+assignT :: (ExtendPath c Int, Monad m) => Translate c m Expr a -> (Name -> a -> b) -> Translate c m Cmd b assignT t f = translate $ \ c cm -> case cm of Assign n e -> f n <$> apply t (c @@ 0) e _ -> fail "not an Assign" -assignR :: Monad m => Rewrite Context m Expr -> Rewrite Context m Cmd+assignR :: (ExtendPath c Int, Monad m) => Rewrite c m Expr -> Rewrite c m Cmd assignR r = assignT r Assign --------------------------------------------------------------------------- -varT :: Monad m => (Name -> b) -> Translate Context m Expr b+varT :: Monad m => (Name -> b) -> Translate c m Expr b varT f = contextfreeT $ \ e -> case e of Var v -> return (f v) _ -> fail "not a Var" --------------------------------------------------------------------------- -litT :: Monad m => (Int -> b) -> Translate Context m Expr b+litT :: Monad m => (Int -> b) -> Translate c m Expr b litT f = contextfreeT $ \ e -> case e of Lit v -> return (f v) _ -> fail "not a Lit" --------------------------------------------------------------------------- -addT :: Monad m => Translate Context m Expr a1 -> Translate Context m Expr a2 -> (a1 -> a2 -> b) -> Translate Context m Expr b+addT :: (ExtendPath c Int, Monad m) => Translate c m Expr a1 -> Translate c m Expr a2 -> (a1 -> a2 -> b) -> Translate c m Expr b addT t1 t2 f = translate $ \ c e -> case e of Add e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2 _ -> fail "not an Add" -addAllR :: Monad m => Rewrite Context m Expr -> Rewrite Context m Expr -> Rewrite Context m Expr+addAllR :: (ExtendPath c Int, Monad m) => Rewrite c m Expr -> Rewrite c m Expr -> Rewrite c m Expr addAllR r1 r2 = addT r1 r2 Add -addAnyR :: MonadCatch m => Rewrite Context m Expr -> Rewrite Context m Expr -> Rewrite Context m Expr+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 :: MonadCatch m => Rewrite Context m Expr -> Rewrite Context m Expr -> Rewrite Context m Expr+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) ---------------------------------------------------------------------------
examples/Fib/AST.hs view
@@ -1,4 +1,4 @@-module Fib.AST where+module Fib.AST (Arith (..)) where data Arith = Lit Int | Add Arith Arith | Sub Arith Arith | Fib Arith deriving Eq
examples/Fib/Examples.hs view
@@ -1,20 +1,22 @@ module Fib.Examples where +import Data.Monoid (mempty)+ import Language.KURE import Fib.AST-import Fib.Kure()+import Fib.Kure ----------------------------------------------------------------------- -- | For this simple example, the context is just an 'AbsolutePath', and 'Translate' always operates on 'Arith'.-type TranslateA b = Translate AbsolutePath KureM Arith b+type TranslateA b = Translate (AbsolutePath Crumb) KureM Arith b type RewriteA = TranslateA Arith ----------------------------------------------------------------------- applyFib :: TranslateA b -> Arith -> Either String b-applyFib r = runKureM Right Left . apply r rootAbsPath+applyFib r = runKureM Right Left . apply r mempty -----------------------------------------------------------------------
examples/Fib/Kure.hs view
@@ -1,23 +1,28 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -module Fib.Kure where+module Fib.Kure (Crumb(..)) where +import Prelude hiding (Left, Right)+ import Language.KURE+ import Fib.AST import Control.Monad(liftM, ap) -------------------------------------------------------------------------------------- -instance Walker AbsolutePath Arith where--- allR :: MonadCatch m => Rewrite AbsolutePath m Arith -> Rewrite AbsolutePath m Arith+data Crumb = LeftChild | RightChild | OnlyChild deriving (Eq,Show)++instance ExtendPath c Crumb => Walker c Arith where+-- allR :: (ExtendPath c Crumb, MonadCatch m) => Rewrite c m Arith -> Rewrite c m Arith allR r = prefixFailMsg "allR failed: " $ rewrite $ \ c e -> case e of Lit n -> Lit <$> return n- Add e0 e1 -> Add <$> apply r (c @@ 0) e0 <*> apply r (c @@ 1) e1- Sub e0 e1 -> Sub <$> apply r (c @@ 0) e0 <*> apply r (c @@ 1) e1- Fib e0 -> Fib <$> apply r (c @@ 0) e0+ Add e0 e1 -> Add <$> apply r (c @@ LeftChild) e0 <*> apply r (c @@ RightChild) e1+ Sub e0 e1 -> Sub <$> apply r (c @@ LeftChild) e0 <*> apply r (c @@ RightChild) e1+ Fib e0 -> Fib <$> apply r (c @@ OnlyChild) e0 --------------------------------------------------------------------------------------
examples/Lam/AST.hs view
@@ -1,4 +1,4 @@-module Lam.AST where+module Lam.AST (Name, Exp(..)) where -------------------------------------------------------------------------------
+ examples/Lam/Context.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE 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
@@ -4,40 +4,13 @@ import Lam.AST import Lam.Kure+import Lam.Context+import Lam.Monad import Data.List (nub) -import Control.Applicative-import Control.Monad import Control.Category ((>>>)) --------------------------------------------------------------------newtype LamM a = LamM {lamM :: Int -> (Int, Either String a)}--runLamM :: LamM a -> Either String a-runLamM m = snd (lamM m 0)--instance Monad LamM where- return a = LamM (\n -> (n,Right a))- (LamM f) >>= gg = LamM $ \ n -> case f n of- (n', Left msg) -> (n', Left msg)- (n', Right a) -> lamM (gg a) n'- fail msg = LamM (\ n -> (n, Left msg))--instance MonadCatch LamM where-- (LamM st) `catchM` f = LamM $ \ n -> case st n of- (n', Left msg) -> lamM (f msg) n'- (n', Right a) -> (n', Right a)--instance Functor LamM where- fmap = liftM--instance Applicative LamM where- pure = return- (<*>) = ap- ------------------------------------------------------------------------------- suggestName :: LamM Name@@ -51,13 +24,13 @@ ------------------------------------------------------------------------------- -type RewriteE = RewriteExp LamM-type TranslateE b = TranslateExp LamM b+type TranslateE b = Translate LamC LamM Exp b+type RewriteE = TranslateE Exp ------------------------------------------------------------------------------- applyExp :: TranslateE b -> Exp -> Either String b-applyExp f = runLamM . apply f initialContext+applyExp f = runLamM . apply f initialLamC ------------------------------------------------------------------------ @@ -96,7 +69,7 @@ beta_reduce :: RewriteE beta_reduce = withPatFailMsg "Cannot beta-reduce, not app-lambda." $ do App (Lam v _) e2 <- idR- pathT [0,0] (tryR $ substExp v e2)+ pathT [App_Fun,Lam_Body] (tryR $ substExp v e2) eta_expand :: RewriteE eta_expand = rewrite $ \ c f -> do v <- freshName (bindings c)
examples/Lam/Kure.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-} module Lam.Kure where @@ -7,42 +7,12 @@ import Language.KURE import Lam.AST-----------------------------------------------------------------------------------data Context = Context AbsolutePath [Name] -- bound variable names--instance PathContext Context where--- absPath :: Context -> AbsolutePath- absPath (Context p _) = p---- (@@) :: Context -> Int -> Context- (Context p vs) @@ n = Context (p @@ n) vs--addBinding :: Name -> Context -> Context-addBinding v (Context p vs) = Context p (v:vs)--initialContext :: Context-initialContext = Context rootAbsPath []--bindings :: Context -> [Name]-bindings (Context _ vs) = vs--boundIn :: Name -> Context -> Bool-boundIn v c = v `elem` bindings c--freeIn :: Name -> Context -> Bool-freeIn v c = not (v `boundIn` c)-----------------------------------------------------------------------------------type TranslateExp m b = Translate Context m Exp b-type RewriteExp m = TranslateExp m Exp+import Lam.Context ------------------------------------------------------------------------------- -instance Walker Context Exp where--- allR :: MonadCatch m => RewriteExp m -> RewriteExp m+instance (ExtendPath c Crumb, AddBoundVar c) => Walker c Exp where+-- allR :: MonadCatch m => Rewrite LamC m Exp -> Rewrite LamC m Exp allR r = prefixFailMsg "allR failed: " $ readerT $ \ e -> case e of App _ _ -> appAllR r r@@ -54,35 +24,35 @@ -- | Congruence combinators. -- Using these ensures that the context is updated consistantly. -varT :: Monad m => (Name -> b) -> TranslateExp m b+varT :: Monad m => (Name -> b) -> Translate c m Exp b varT f = contextfreeT $ \ e -> case e of Var n -> return (f n) _ -> fail "no match for Var" ------------------------------------------------------------------------------- -lamT :: Monad m => TranslateExp m a -> (Name -> a -> b) -> TranslateExp m b+lamT :: (ExtendPath c Crumb, AddBoundVar c, Monad m) => Translate c m Exp a -> (Name -> a -> b) -> Translate c m Exp b lamT t f = translate $ \ c e -> case e of- Lam v e1 -> f v <$> apply t (addBinding v c @@ 0) e1+ Lam v e1 -> f v <$> apply t (addBoundVar v c @@ Lam_Body) e1 _ -> fail "no match for Lam" -lamR :: Monad m => RewriteExp m -> RewriteExp m+lamR :: (ExtendPath c Crumb, AddBoundVar c, Monad m) => Rewrite c m Exp -> Rewrite c m Exp lamR r = lamT r Lam ------------------------------------------------------------------------------- -appT :: Monad m => TranslateExp m a1 -> TranslateExp m a2 -> (a1 -> a2 -> b) -> TranslateExp m b+appT :: (ExtendPath c Crumb, Monad m) => Translate c m Exp a1 -> Translate c m Exp a2 -> (a1 -> a2 -> b) -> Translate c m Exp b appT t1 t2 f = translate $ \ c e -> case e of- App e1 e2 -> f <$> apply t1 (c @@ 0) e1 <*> apply t2 (c @@ 1) e2+ App e1 e2 -> f <$> apply t1 (c @@ App_Fun) e1 <*> apply t2 (c @@ App_Arg) e2 _ -> fail "no match for App" -appAllR :: Monad m => RewriteExp m -> RewriteExp m -> RewriteExp m+appAllR :: (ExtendPath c Crumb, Monad m) => Rewrite c m Exp -> Rewrite c m Exp -> Rewrite c m Exp appAllR r1 r2 = appT r1 r2 App -appAnyR :: MonadCatch m => RewriteExp m -> RewriteExp m -> RewriteExp m+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 :: MonadCatch m => RewriteExp m -> RewriteExp m -> RewriteExp m+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,35 @@+module Lam.Monad where++import Language.KURE++import Control.Applicative+import Control.Monad++-------------------------------------------------------------------------------++newtype LamM a = LamM {lamM :: Int -> (Int, Either String a)}++runLamM :: LamM a -> Either String a+runLamM m = snd (lamM m 0)++instance Monad LamM where+ return a = LamM (\n -> (n,Right a))+ (LamM f) >>= gg = LamM $ \ n -> case f n of+ (n', Left msg) -> (n', Left msg)+ (n', Right a) -> lamM (gg a) n'+ fail msg = LamM (\ n -> (n, Left msg))++instance MonadCatch LamM where++ (LamM st) `catchM` f = LamM $ \ n -> case st n of+ (n', Left msg) -> lamM (f msg) n'+ (n', Right a) -> (n', Right a)++instance Functor LamM where+ fmap = liftM++instance Applicative LamM where+ pure = return+ (<*>) = ap++-------------------------------------------------------------------------------
kure.cabal view
@@ -1,5 +1,5 @@ Name: kure-Version: 2.6.22+Version: 2.8.0 Synopsis: Combinators for Strategic Programming Description: The Kansas University Rewrite Engine (KURE) is a domain-specific language for strategic rewriting. KURE was inspired by Stratego and StrategyLib, and has similarities with Scrap Your Boilerplate and Uniplate.@@ -30,9 +30,12 @@ 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 @@ -51,6 +54,7 @@ Language.KURE.Injection Language.KURE.Lens Language.KURE.MonadCatch+ Language.KURE.Path Language.KURE.Translate Language.KURE.Walker