diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2006-2009 Andy Gill +(c) 2006-2012 The University of Kansas All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Language/KURE.hs b/Language/KURE.hs --- a/Language/KURE.hs +++ b/Language/KURE.hs @@ -1,26 +1,25 @@ -- | -- Module: Language.KURE --- Copyright: (c) 2006-2008 Andy Gill +-- Copyright: (c) 2012 The University of Kansas -- License: BSD3 -- --- Maintainer: Andy Gill --- Stability: unstable +-- Maintainer: Neil Sculthorpe +-- 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.Translate", +-- and the traversal functionality can be found in "Language.KURE.Walker". -- +-- Note that "Language.KURE.Injection" and "Language.KURE.Utilities" are not exported here, but can be imported seperately. -module Language.KURE - ( module Language.KURE.RewriteMonad - , module Language.KURE.Translate - , module Language.KURE.Rewrite - , module Language.KURE.Combinators - , module Language.KURE.Term - ) where -import Language.KURE.RewriteMonad -import Language.KURE.Translate -import Language.KURE.Rewrite +module Language.KURE + ( module Language.KURE.Translate + , module Language.KURE.Walker + , module Language.KURE.Combinators +) where + import Language.KURE.Combinators -import Language.KURE.Term +import Language.KURE.Translate +import Language.KURE.Walker diff --git a/Language/KURE/Combinators.hs b/Language/KURE/Combinators.hs --- a/Language/KURE/Combinators.hs +++ b/Language/KURE/Combinators.hs @@ -1,193 +1,145 @@ +{-# LANGUAGE TypeOperators, TupleSections #-} + -- | --- Module: Language.KURE.Combinators --- Copyright: (c) 2006-2008 Andy Gill +-- Module: Language.KURE.Combinators +-- Copyright: (c) 2012 The University of Kansas -- License: BSD3 -- --- Maintainer: Andy Gill --- Stability: unstable +-- Maintainer: Neil Sculthorpe +-- 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 +-- This module provides various monadic and arrow combinators that are particularly useful when +-- working with translations. +-- Note that these combinators assume that 'mplus' behaves as a catch, for both 'fail' and 'mzero'. --- | 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 +module Language.KURE.Combinators + ( -- * Monad Combinators + guardFail + , condM + , whenM + , tryM + , mtryM + , attemptM + , testM + , notM + -- * Arrow Combinators + -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators. + , result + , argument + , idR + , (<+) + , readerR + , acceptR + , tryR + , attemptR + , changedR + , repeatR + , (>+>) + , orR + , andR +) where --- | 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 +import Prelude hiding (id , (.)) +import Control.Monad +import Control.Category +import Control.Arrow +import Data.Maybe (isJust) +import Data.Monoid --- | 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) +infixl 3 <+, >+> --- | '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 +-- | Similar to 'guard', but using 'fail' rather than 'mzero'. +guardFail :: Monad m => Bool -> String -> m () +guardFail b msg = unless b (fail msg) --- | '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-then-else lifted over a 'Monad'. +condM :: Monad m => m Bool -> m a -> m a -> m a +condM mb m1 m2 = do b <- mb + if b then m1 else m2 --- | 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-then lifted over a 'Monad'. +whenM :: Monad m => m Bool -> m a -> m a +whenM mb ma = condM mb ma (fail "condition False") --- | 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 monadic computation, making it succeed with a constant value. +tryM :: MonadPlus m => a -> m a -> m a +tryM a ma = ma `mplus` return a --- | 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 +-- | Catch a failing monadic computation, making it succeed with 'mempty'. +mtryM :: (MonadPlus m, Monoid a) => m a -> m a +mtryM = tryM mempty --- | 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" +-- | Catch a failing monadic computation, making it succeed with 'Nothing'. +attemptM :: MonadPlus m => m a -> m (Maybe a) +attemptM = tryM Nothing . liftM Just --- | 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) +-- | Determine if a monadic computation succeeds. +testM :: MonadPlus m => m a -> m Bool +testM = liftM isJust . attemptM --- | 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" +-- | Fail if the 'Monad' succeeds; succeed with @()@ if it fails. +notM :: MonadPlus m => m a -> m () +notM ma = attemptM ma >>= maybe (return ()) (const mzero) +------------------------------------------------------------------------------------------ --- | identity rewrite. -idR :: (Monad m, Monoid dec) => Rewrite m dec exp -idR = transparently $ rewrite $ \ e -> return e +-- | Apply a pure function to the result of an 'Arrow'. +result :: Arrow (~>) => (b -> c) -> (a ~> b) -> (a ~> c) +result f a = a >>^ f --- | failing rewrite. -failR :: (Monad m, Monoid dec) => String -> Rewrite m dec a -failR = failT +-- | Apply a pure function to the argument to an 'Arrow'. +argument :: Arrow (~>) => (a -> b) -> (b ~> c) -> (a ~> c) +argument f a = f ^>> a --------------------------------------------------------------------------------- --- 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) +-- | Synonym for 'id'. +idR :: Category (~>) => (a ~> a) +idR = id -listR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec [a] -listR rr = transparently $ rewrite $ mapM (apply rr) +-- | Synonym for '<+>'. +(<+) :: ArrowPlus (~>) => (a ~> b) -> (a ~> b) -> (a ~> b) +(<+) = (<+>) -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 +-- | Look at the argument to the 'Arrow' before choosing which 'Arrow' to use. +readerR :: ArrowApply (~>) => (a -> (a ~> b)) -> (a ~> b) +readerR f = (f &&& id) ^>> app -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) +-- | Look at the argument to an 'Arrow', and choose to be either the identity arrow or the zero arrow. +acceptR :: (ArrowZero (~>), ArrowApply (~>)) => (a -> Bool) -> (a ~> a) +acceptR p = readerR $ \ a -> if p a then id else zeroArrow -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) +-- | Catch a failing 'ArrowPlus', making it into an identity. +tryR :: ArrowPlus (~>) => (a ~> a) -> (a ~> a) +tryR r = r <+> id -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 +-- | Catch a failing 'ArrowPlus', making it succeed with a Boolean flag. +-- Useful when defining 'anyR' instances. +attemptR :: ArrowPlus (~>) => (a ~> a) -> (a ~> (Bool,a)) +attemptR r = (r >>^ (True,)) <+> arr (False,) --------------------------------------------------------------------------------- --- | Failable structure. -class Failable f where - failure :: String -> f a +-- | Makes an 'Arrow' fail if the result value equals the argument value. +changedR :: (ArrowPlus (~>), ArrowApply (~>), Eq a) => (a ~> a) -> (a ~> a) +changedR r = readerR (\ a -> r >>> acceptR (/=a)) -instance (Monad m, Monoid dec) => Failable (Translate m dec a) where - failure msg = failT msg +-- | Repeat an 'ArrowPlus' until it fails, then return the result before the failure. +-- Requires at least the first attempt to succeed. +repeatR :: ArrowPlus (~>) => (a ~> a) -> (a ~> a) +repeatR r = r >>> tryR (repeatR r) -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 +-- | Attempts two 'Arrows's in sequence, succeeding if one or both succeed. +(>+>) :: (ArrowPlus (~>), ArrowApply (~>)) => (a ~> a) -> (a ~> a) -> (a ~> a) +r1 >+> r2 = attemptR r1 >>> readerR (\ (b,_) -> snd ^>> if b then tryR r2 else r2) +-- | Sequence a list of 'Arrow's, succeeding if any succeed. +orR :: (ArrowZero (~>), ArrowPlus (~>), ArrowApply (~>)) => [a ~> a] -> (a ~> a) +orR = foldl (>+>) zeroArrow --------------------------------------------------------------------------------- --- 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') +-- | Sequence a list of 'Arrow's, succeeding if they all succeed. +andR :: Arrow (~>) => [a ~> a] -> (a ~> a) +andR = foldl (>>>) id +------------------------------------------------------------------------------- diff --git a/Language/KURE/Injection.hs b/Language/KURE/Injection.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Injection.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +-- | +-- Module: Language.KURE.Injection +-- Copyright: (c) 2012 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- Stability: beta +-- Portability: ghc +-- +-- This module provides a type class for injective functions (and their retractions), +-- and some useful interactions with 'Translate'. +-- +-- A particularly useful instance of 'Injection' is from @a@ to 'Generic' @a@, +-- and that case is the primary purpose of most of these combinators. + +module Language.KURE.Injection + ( -- * Injection Class + Injection(..) + -- * Monad Injections + , injectM + , retractM + -- * Translate Injections + , injectT + , retractT + , extractT + , promoteT + , extractR + , promoteR + -- * Lens Injections + , injectL + , retractL +) where + +import Control.Monad +import Control.Arrow + +import Language.KURE.Translate + +------------------------------------------------------------------------------- + +-- | A class of injective functions from @a@ to @b@, and their retractions. +-- The following law is expected to hold: +-- +-- > retract (inject a) == Just a + +class Injection a b where + inject :: a -> b + retract :: b -> Maybe a + +-- | There is an identity injection for all types. +instance Injection a a where + inject = id + retract = Just + +instance Injection a (Maybe a) where + inject = Just + retract = id + +------------------------------------------------------------------------------- + +-- | Injects a value and lifts it into a 'Monad'. +injectM :: (Monad m, Injection a a') => a -> m a' +injectM = return . inject + +-- | Retracts a value and lifts it into a 'MonadPlus', producing 'mzero' if the retraction fails. +retractM :: (MonadPlus m, Injection a a') => a' -> m a +retractM = maybe mzero return . retract + +------------------------------------------------------------------------------- + +-- | Lifted 'inject'. +injectT :: (Monad m, Injection a a') => Translate c m a a' +injectT = arr inject + +-- | Lifted 'retract', the 'Translate' fails if the retraction fails. +retractT :: (MonadPlus m, Injection a a') => Translate c m a' a +retractT = contextfreeT retractM + +-- | Convert a 'Translate' over an injected value into a 'Translate' over a non-injected value. +extractT :: (Monad m, Injection a a') => Translate c m a' b -> Translate c m a b +extractT t = injectT >>> t + +-- | Promote a 'Translate' over a value into a 'Translate' over an injection of that value, +-- (failing if that injected value cannot be retracted). +promoteT :: (MonadPlus m, Injection a a') => Translate c m a b -> Translate c m a' b +promoteT t = retractT >>> t + +-- | Convert a 'Rewrite' over an injected value into a 'Rewrite' over a retraction of that value, +-- (failing if that injected value cannot be retracted). +extractR :: (MonadPlus m, Injection a a') => Rewrite c m a' -> Rewrite c m a +extractR r = injectT >>> r >>> retractT + +-- | Promote a 'Rewrite' into over a value into a 'Rewrite' over an injection of that value, +-- (failing if that injected value cannot be retracted). +promoteR :: (MonadPlus m, Injection a a') => Rewrite c m a -> Rewrite c m a' +promoteR r = retractT >>> r >>> injectT + +------------------------------------------------------------------------------- + +-- | A 'Lens' to the injection of a value. +injectL :: (MonadPlus m, Injection a a') => Lens c m a a' +injectL = lens $ \ c a -> return ((c, inject a), retractM) + +-- | A 'Lens' to the retraction of a value. +retractL :: (MonadPlus m, Injection a a') => Lens c m a' a +retractL = lens $ \ c -> retractM >=> (\ a -> return ((c,a), injectM)) + +------------------------------------------------------------------------------- diff --git a/Language/KURE/Rewrite.hs b/Language/KURE/Rewrite.hs deleted file mode 100644 --- a/Language/KURE/Rewrite.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | --- Module: Language.KURE.Rewrite --- Copyright: (c) 2006-2008 Andy Gill --- License: BSD3 --- --- Maintainer: Andy Gill --- 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 diff --git a/Language/KURE/RewriteMonad.hs b/Language/KURE/RewriteMonad.hs deleted file mode 100644 --- a/Language/KURE/RewriteMonad.hs +++ /dev/null @@ -1,165 +0,0 @@ --- | --- Module: Language.KURE.RewriteMonad --- Copyright: (c) 2006-2008 Andy Gill --- License: BSD3 --- --- Maintainer: Andy Gill --- 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) - diff --git a/Language/KURE/Term.hs b/Language/KURE/Term.hs deleted file mode 100644 --- a/Language/KURE/Term.hs +++ /dev/null @@ -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) ] - -------------------------------------------------------------------------------- diff --git a/Language/KURE/Translate.hs b/Language/KURE/Translate.hs --- a/Language/KURE/Translate.hs +++ b/Language/KURE/Translate.hs @@ -1,70 +1,229 @@ -- | --- Module: Language.KURE.Translate --- Copyright: (c) 2006-2008 Andy Gill +-- Module: Language.KURE.Translate +-- Copyright: (c) 2012 The University of Kansas -- License: BSD3 -- --- Maintainer: Andy Gill --- Stability: unstable +-- Maintainer: Neil Sculthorpe +-- Stability: beta -- Portability: ghc -- --- 'Translate' is the main abstraction inside KURE, and represents a rewriting from a source to a target --- of a possibly different type. +-- This module defines the main KURE types: 'Translate', 'Rewrite' and 'Lens'. +-- 'Rewrite' and 'Lens' are just special cases of 'Translate', and so any function that operates on 'Translate' is also +-- applicable to 'Rewrite' and 'Lens' (although care should be taken in the 'Lens' case). -- --- Rewrite (defined in 'Language.KURE.Rewrite') is a synonoym for a 'Translate' with the same source and target type. +-- This module also contains 'Translate' instance declarations for the 'Monad' and 'Arrow' type-class families. +-- Given these instances, many of the desirable combinators over 'Translate' and 'Rewrite' are special cases +-- of existing monadic or arrow combinators. +-- "Language.KURE.Combinators" provides some additional combinators that aren't in the standard libraries. -module Language.KURE.Translate - ( Translate - , apply - , runTranslate - , transparently - , translate - ) where - +module Language.KURE.Translate + ( -- * Translations + Translate(..) + , Rewrite + , translate + , rewrite + , contextfreeT + , constT + , contextT + , exposeT + , mapT + -- * Lenses + , Lens + , lens + , idL + , tryL + , composeL + , sequenceL + , pureL + , focusR + , focusT + +) where + +import Prelude hiding (id, (.)) +import Control.Applicative import Control.Monad +import Control.Category +import Control.Arrow 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. +-- | 'Translate' is a translation or strategy that translates from a value in a context to a monadic value. +data Translate c m a b = Translate { -- | Apply a 'Translate' to a value and its context. + apply :: c -> a -> m b} -newtype Translate m dec exp1 exp2 = - Translate ( exp1 -> RewriteM m dec exp2 ) +-- | A 'Rewrite' is a 'Translate' that shares the same source and target type. +type Rewrite c m a = Translate c m a a --- | '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 +-- | The primitive way of building a 'Translate'. +translate :: (c -> a -> m b) -> Translate c m a b +translate = Translate --- | '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. +-- | The primitive way of building a 'Rewrite'. +rewrite :: (c -> a -> m a) -> Rewrite c m a +rewrite = translate -translate :: (Monoid dec, Monad m) => (exp1 -> RewriteM m dec exp2) -> Translate m dec exp1 exp2 -translate f = Translate $ \ e -> markM $ f e +------------------------------------------------------------------------------------------ +-- | Build a 'Translate' that doesn't depend on the context. +contextfreeT :: (a -> m b) -> Translate c m a b +contextfreeT = translate . const --- | '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. +-- | Build a constant 'Translate' from a monadic computation. +constT :: m b -> Translate c m a b +constT = contextfreeT . const -transparently :: (Monoid dec, Monad m) => Translate m dec exp1 exp2 -> Translate m dec exp1 exp2 -transparently (Translate m) = Translate $ \ e -> transparentlyM (m e) +-- | Extract the current context. +contextT :: Monad m => Translate c m a c +contextT = translate (\ c _ -> return c) --- | 'runTranslate' executes the translation, returning either a failure message, --- or a success and the new parts of the environment. +-- | Expose the current context and value. +exposeT :: Monad m => Translate c m a (c,a) +exposeT = translate (curry return) -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) +-- | Map a 'Translate' over a list. +mapT :: Monad m => Translate c m a b -> Translate c m [a] [b] +mapT t = translate (mapM . apply t) +------------------------------------------------------------------------------------------ + +-- | Lifting through a Reader transformer, where (c,a) is the read-only environment. +instance Functor m => Functor (Translate c m a) where + +-- fmap :: (b -> d) -> Translate c m a b -> Translate c m a d + fmap f t = translate (\ c -> fmap f . apply t c) + +-- | Lifting through a Reader transformer, where (c,a) is the read-only environment. +instance Applicative m => Applicative (Translate c m a) where + +-- pure :: b -> Translate c m a b + pure = constT . pure + +-- (<*>) :: Translate c m a (b -> d) -> Translate c m a b -> Translate c m a d + tf <*> tb = translate (\ c a -> apply tf c a <*> apply tb c a) + +-- | Lifting through a Reader transformer, where (c,a) is the read-only environment. +instance Alternative m => Alternative (Translate c m a) where + +-- empty :: Translate c m a b + empty = constT empty + +-- (<|>) :: Translate c m a b -> Translate c m a b -> Translate c m a b + t1 <|> t2 = translate $ \ c a -> apply t1 c a <|> apply t2 c a + +-- | Lifting through a Reader transformer, where (c,a) is the read-only environment. +instance Monad m => Monad (Translate c m a) where + +-- return :: b -> Translate c m a b + return = constT . return + +-- (>>=) :: Translate c m a b -> (b -> Translate c m a d) -> Translate c m a d + t >>= f = translate $ \ c a -> do b <- apply t c a + apply (f b) c a + +-- fail :: String -> Translate c m a b + fail = constT . fail + +-- | Lifting through a Reader transformer, where (c,a) is the read-only environment. +instance MonadPlus m => MonadPlus (Translate c m a) where + +-- mzero :: Translate c m a b + mzero = constT mzero + +-- mplus :: Translate c m a b -> Translate c m a b -> Translate c m a b + mplus t1 t2 = translate $ \ c a -> apply t1 c a `mplus` apply t2 c a + +-- | The 'Kleisli' 'Category' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. +instance Monad m => Category (Translate c m) where + +-- id :: Translate c m a a + id = contextfreeT return + +-- (.) :: Translate c m b d -> Translate c m a b -> Translate c m a d + t2 . t1 = translate $ \ c -> apply t1 c >=> apply t2 c + +-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. +instance Monad m => Arrow (Translate c m) where + +-- arr :: (a -> b) -> Translate c m a b + arr f = contextfreeT (return . f) + +-- first :: (a -> b) -> Translate c m (a,z) (b,z) + first t = translate $ \ c (a,z) -> liftM (\b -> (b,z)) (apply t c a) + +-- (***) :: Translate c m a1 b1 -> Translate c m a2 b2 -> Translate c m (a1,a2) (b1,b2) + t1 *** t2 = translate $ \ c (a,b) -> liftM2 (,) (apply t1 c a) (apply t2 c b) + +-- (&&&) :: Translate c m a b1 -> Translate c m a b2 -> Translate c m a (b1,b2) + t1 &&& t2 = translate $ \ c a -> liftM2 (,) (apply t1 c a) (apply t2 c a) + +-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. +instance MonadPlus m => ArrowZero (Translate c m) where + +-- zeroArrow :: Translate c m a b + zeroArrow = mzero + +-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. +instance MonadPlus m => ArrowPlus (Translate c m) where + +-- (<+>) :: Translate c m a b -> Translate c m a b -> Translate c m a b + (<+>) = mplus + +-- | The 'Kleisli' 'Arrow' induced by @m@, lifting through a Reader transformer, where @c@ is the read-only environment. +instance Monad m => ArrowApply (Translate c m) where + +-- app :: Translate c m (Translate c m a b, a) b + app = translate $ \ c (t,a) -> apply t c a + +-- | Lifting through the 'Monad' and a Reader transformer, where (c,a) is the read-only environment. +instance (Monad m, Monoid b) => Monoid (Translate c m a b) where + +-- mempty :: Translate c m a b + mempty = return mempty + +-- mappend :: Translate c m a b -> Translate c m a b -> Translate c m a b + mappend = liftM2 mappend + +------------------------------------------------------------------------------------------ + +-- | A 'Lens' is a way to focus in on a particular point in a structure. +type Lens c m a b = Translate c m a ((c,b), b -> m a) + +-- | 'lens' is the primitive way of building a 'Lens'. +lens :: (c -> a -> m ((c,b), b -> m a)) -> Lens c m a b +lens = translate + +-- | Identity 'Lens'. +idL :: Monad m => Lens c m a a +idL = lens $ \ c a -> return ((c,a), return) + +-- | Catch a failing endo'Lens', making it into an identity. +tryL :: MonadPlus m => Lens c m a a -> Lens c m a a +tryL l = l <+> idL + +-- | Composition of 'Lens's. +composeL :: Monad m => Lens c m a b -> Lens c m b d -> Lens c m a d +composeL l1 l2 = lens $ \ ca a -> do ((cb,b),kb) <- apply l1 ca a + ((cd,d),kd) <- apply l2 cb b + return ((cd,d),kd >=> kb) + +-- | Sequence a list of endo'Lens's. +sequenceL :: MonadPlus m => [Lens c m a a] -> Lens c m a a +sequenceL = foldr composeL idL + +-- | Construct a 'Lens' from two pure functions. +pureL :: Monad m => (a -> b) -> (b -> a) -> Lens c m a b +pureL f g = lens (\ c a -> return ((c,f a), return . g)) + +-- | 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 = rewrite $ \ c a -> do ((c',b),k) <- apply l c a + apply r c' b >>= k + +-- | Apply a 'Translate' at a point specified by a 'Lens'. +focusT :: Monad m => Lens c m a b -> Translate c m b d -> Translate c m a d +focusT l t = translate $ \ c a -> do ((c',b),_) <- apply l c a + apply t c' b + +------------------------------------------------------------------------------------------ diff --git a/Language/KURE/Utilities.hs b/Language/KURE/Utilities.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Utilities.hs @@ -0,0 +1,176 @@ +-- | +-- Module: Language.KURE.Utilities +-- Copyright: (c) 2012 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- Stability: beta +-- Portability: ghc +-- +-- This module contains several utility functions that can be useful to users of KURE, +-- when definining instances of the KURE classes. + +module Language.KURE.Utilities + ( -- * Generic Combinators + -- $genericdoc + allTgeneric + , allRgeneric + , anyRgeneric + , childLgeneric + -- * Attempt Combinators + -- $attemptdoc + , attemptAny2 + , attemptAny3 + , attemptAnyN + , attemptAny1N + -- * Error Messages + , missingChildL + -- * Child Combinators + -- $childLdoc + , childLaux + , childL0of1 + , childL0of2 + , childL1of2 + , childL0of3 + , childL1of3 + , childL2of3 + , childL0of4 + , childL1of4 + , childL2of4 + , childL3of4 + , childLMofN +) where + +import Control.Monad +import Control.Arrow + +import Data.Monoid + +import Language.KURE.Combinators +import Language.KURE.Translate +import Language.KURE.Walker +import Language.KURE.Injection + +------------------------------------------------------------------------------- + +-- $genericdoc +-- These functions are to aid with defining 'Walker' instances for the 'Generic' type. +-- See the \"Expr\" example. + +allTgeneric :: (Walker c m a, Monoid b) => Translate c m (Generic a) b -> c -> a -> m b +allTgeneric t c a = inject `liftM` apply (allT t) c a + +allRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a) +allRgeneric r c a = inject `liftM` apply (allR r) c a + +anyRgeneric :: Walker c m a => Rewrite c m (Generic a) -> c -> a -> m (Generic a) +anyRgeneric r c a = inject `liftM` apply (anyR r) c a + +childLgeneric :: Walker c m a => Int -> c -> a -> m ((c, Generic a), Generic a -> m (Generic a)) +childLgeneric n c a = (liftM.second.result.liftM) inject $ apply (childL n) c a + +------------------------------------------------------------------------------- + +-- $attemptdoc +-- These are useful when defining congruence combinators that succeed if any child rewrite succeeds. +-- As well as being generally useful, such combinators are helpful when defining 'anyR' instances. +-- See the \"Lam\" or \"Expr\" examples, or the HERMIT package. + +attemptAny2 :: Monad m => (a1 -> a2 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m r +attemptAny2 f mba1 mba2 = do (b1,a1) <- mba1 + (b2,a2) <- mba2 + if b1 || b2 + then return (f a1 a2) + else fail "failed for both children." + +attemptAny3 :: Monad m => (a1 -> a2 -> a3 -> r) -> m (Bool,a1) -> m (Bool,a2) -> m (Bool,a3) -> m r +attemptAny3 f mba1 mba2 mba3 = do (b1,a1) <- mba1 + (b2,a2) <- mba2 + (b3,a3) <- mba3 + if b1 || b2 || b3 + then return (f a1 a2 a3) + else fail "failed for all three children." + +attemptAnyN :: Monad m => ([a] -> b) -> [m (Bool,a)] -> m b +attemptAnyN f mbas = do (bs,as) <- unzip `liftM` sequence mbas + if or bs + then return (f as) + else fail ("failed for all " ++ show (length bs) ++ " children.") + +attemptAny1N :: Monad m => (a1 -> [a2] -> r) -> m (Bool,a1) -> [m (Bool,a2)] -> m r +attemptAny1N f mba mbas = do (b ,a) <- mba + (bs,as) <- unzip `liftM` sequence mbas + if or (b:bs) + then return (f a as) + else fail ("failed for all " ++ show (1 + length bs) ++ " children.") + +------------------------------------------------------------------------------- + +-- | A failing 'Lens' with a standard error message for when the child index is out of bounds. + +missingChildL :: Monad m => Int -> Lens c m a b +missingChildL n = fail ("There is no child number " ++ show n ++ ".") + +------------------------------------------------------------------------------- + +-- $childLdoc +-- These functions are helpful when defining 'childL' instances in combination with congruence combinators. +-- See the \"Lam\" and \"Expr\" examples, or the HERMIT package. +-- +-- Unfortunately they increase quadratically with the number of fields of the constructor. +-- It would be nice if they were further expanded to include the calls of 'idR' and 'exposeT'; +-- however this would create a plethora of additional cases as the number (and positions) +-- of interesting children would be additional dimensions. +-- +-- Note that the numbering scheme MofN is that N is the number of children (including uninteresting children) +-- and M is the index of the chosen child, starting with index 0. Thus M ranges from 0 to (n-1). +-- +-- TO DO: use Template Haskell to generate these. +-- +-- In the mean time, if you need a few more than provided here, drop me an email and I'll add them. + +childLaux :: (MonadPlus m, Term b) => (c,b) -> (b -> a) -> ((c, Generic b), Generic b -> m a) +childLaux cb g = (second inject cb, liftM (inject.g) . retractM) + +childL0of1 :: (MonadPlus m, Term b) => (b -> a) -> (c,b) -> ((c, Generic b) , Generic b -> m a) +childL0of1 f cb = childLaux cb f + +childL0of2 :: (MonadPlus m, Term b0) => (b0 -> b1 -> a) -> (c,b0) -> b1 -> ((c, Generic b0) , Generic b0 -> m a) +childL0of2 f cb0 b1 = childLaux cb0 (\ b0 -> f b0 b1) + +childL1of2 :: (MonadPlus m, Term b1) => (b0 -> b1 -> a) -> b0 -> (c,b1) -> ((c, Generic b1) , Generic b1 -> m a) +childL1of2 f b0 cb1 = childLaux cb1 (\ b1 -> f b0 b1) + +childL0of3 :: (MonadPlus m, Term b0) => (b0 -> b1 -> b2 -> a) -> (c,b0) -> b1 -> b2 -> ((c, Generic b0) , Generic b0 -> m a) +childL0of3 f cb0 b1 b2 = childLaux cb0 (\ b0 -> f b0 b1 b2) + +childL1of3 :: (MonadPlus m, Term b1) => (b0 -> b1 -> b2 -> a) -> b0 -> (c,b1) -> b2 -> ((c, Generic b1) , Generic b1 -> m a) +childL1of3 f b0 cb1 b2 = childLaux cb1 (\ b1 -> f b0 b1 b2) + +childL2of3 :: (MonadPlus m, Term b2) => (b0 -> b1 -> b2 -> a) -> b0 -> b1 -> (c,b2) -> ((c, Generic b2) , Generic b2 -> m a) +childL2of3 f b0 b1 cb2 = childLaux cb2 (\ b2 -> f b0 b1 b2) + +childL0of4 :: (MonadPlus m, Term b0) => (b0 -> b1 -> b2 -> b3 -> a) -> (c,b0) -> b1 -> b2 -> b3 -> ((c, Generic b0) , Generic b0 -> m a) +childL0of4 f cb0 b1 b2 b3 = childLaux cb0 (\ b0 -> f b0 b1 b2 b3) + +childL1of4 :: (MonadPlus m, Term b1) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> (c,b1) -> b2 -> b3 -> ((c, Generic b1) , Generic b1 -> m a) +childL1of4 f b0 cb1 b2 b3 = childLaux cb1 (\ b1 -> f b0 b1 b2 b3) + +childL2of4 :: (MonadPlus m, Term b2) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> b1 -> (c,b2) -> b3 -> ((c, Generic b2) , Generic b2 -> m a) +childL2of4 f b0 b1 cb2 b3 = childLaux cb2 (\ b2 -> f b0 b1 b2 b3) + +childL3of4 :: (MonadPlus m, Term b3) => (b0 -> b1 -> b2 -> b3 -> a) -> b0 -> b1 -> b2 -> (c,b3) -> ((c, Generic b3) , Generic b3 -> m a) +childL3of4 f b0 b1 b2 cb3 = childLaux cb3 (\ b3 -> f b0 b1 b2 b3) + +childLMofN :: (MonadPlus m, Term b) => Int -> ([b] -> a) -> [(c,b)] -> ((c, Generic b) , Generic b -> m a) +childLMofN m f cbs = childLaux (cbs !! m) (\ b' -> f $ atIndex m (const b') (map snd cbs)) + +------------------------------------------------------------------------------- + +-- | Modify the value in a list at specified index. +atIndex :: Int -> (a -> a) -> [a] -> [a] +atIndex i f as = [ if n == i then f a else a + | (a,n) <- zip as [0..] + ] + +------------------------------------------------------------------------------- diff --git a/Language/KURE/Walker.hs b/Language/KURE/Walker.hs new file mode 100644 --- /dev/null +++ b/Language/KURE/Walker.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-} + +-- | +-- Module: Language.KURE.Walker +-- Copyright: (c) 2012 The University of Kansas +-- License: BSD3 +-- +-- Maintainer: Neil Sculthorpe +-- 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. +-- There is no mechanism for \"ascending\" the tree. + +module Language.KURE.Walker + ( -- * Traversal Classes + Term(..) + , Walker(..) + + -- * Rewrite Traversals + , childR + , alltdR + , anytdR + , allbuR + , anybuR + , allduR + , anyduR + , tdpruneR + , innermostR + + -- * Translate Traversals + , childT + , foldtdT + , foldbuT + , tdpruneT + , crushtdT + , crushbuT + + -- * Building Lenses + , Path + , pathL + , exhaustPathL + , repeatPathL +) where + +import Data.Monoid +import Control.Monad +import Control.Arrow + +import Language.KURE.Combinators +import Language.KURE.Translate +import Language.KURE.Injection + +------------------------------------------------------------------------------------------ + +-- | A 'Term' is any node in the tree that you wish to be able to traverse. + +class (Injection a (Generic a), Generic a ~ Generic (Generic a)) => Term a where + + -- | 'Generic' is a sum of all the interesting sub-types, transitively, of @a@. + -- We use @Generic a ~ a@ to signify that something is its own Generic. + -- Simple expression types might be their own sole 'Generic', more complex examples + -- will have a new datatype for the 'Generic', which will also be an instance of class 'Term'. + type Generic a :: * + + -- | Count the number of interesting children. + numChildren :: a -> Int + +------------------------------------------------------------------------------- + +-- | 'Walker' captures the ability to walk over a 'Term' applying 'Rewrite's, +-- using a specific context @c@ and a 'MonadPlus' @m@. +-- +-- Minimal complete definition: 'childL'. +-- +-- Default instances are provided for 'allT', 'allR' and 'anyR', but they may be overridden for efficiency. +-- For small numbers of interesting children this will not be an issue, but for a large number, say +-- for a list of children, it may be. + +class (MonadPlus m, Term a) => Walker c m a where + + -- | Construct a 'Lens' pointing at the n-th interesting child of this node. + childL :: Int -> Lens c m a (Generic a) + + -- | Apply a 'Generic' 'Translate' to all interesting children of this node, succeeding if they all succeed. + -- The results are combined in a 'Monoid'. + allT :: Monoid b => Translate c m (Generic a) b -> Translate c m a b + allT t = do n <- arr numChildren + mconcat [ childT i t | i <- [0..(n-1)] ] + + -- | Apply a 'Generic' 'Rewrite' to all interesting children of this node, succeeding if they all succeed. + allR :: Rewrite c m (Generic a) -> Rewrite c m a + allR r = do n <- arr numChildren + andR [ childR i r | i <- [0..(n-1)] ] + + -- | Apply 'Generic' 'Rewrite' to all interesting children of this node, suceeding if any succeed. + anyR :: Rewrite c m (Generic a) -> Rewrite c m a + anyR r = do n <- arr numChildren + orR [ childR i r | i <- [0..(n-1)] ] + +-- | Apply a 'Translate' to a specific child. +childT :: Walker c m a => Int -> Translate c m (Generic a) b -> Translate c m a b +childT n = focusT (childL n) + +-- | Apply a 'Rewrite' to a specific child. +childR :: Walker c m a => Int -> Rewrite c m (Generic a) -> Rewrite c m a +childR n = focusR (childL n) + +------------------------------------------------------------------------------- + +-- | Fold a tree in a top-down manner, using a single 'Translate' for each node. +foldtdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b +foldtdT t = t `mappend` allT (foldtdT t) + +-- | Fold a tree in a bottom-up manner, using a single 'Translate' for each node. +foldbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b +foldbuT t = allT (foldbuT t) `mappend` t + +-- | Attempt to apply a 'Translate' in a top-down manner, prunning at successes. +tdpruneT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b +tdpruneT t = t <+> allT (tdpruneT t) + +-- | An always successful top-down fold, replacing failures with 'mempty'. +crushtdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b +crushtdT t = foldtdT (mtryM t) + +-- | An always successful bottom-up fold, replacing failures with 'mempty'. +crushbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b +crushbuT t = foldbuT (mtryM t) + +------------------------------------------------------------------------------- + +-- | Apply a 'Rewrite' in a top-down manner, succeeding if they all succeed. +alltdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +alltdR r = r >>> allR (alltdR r) + +-- | Apply a 'Rewrite' in a top-down manner, succeeding if any succeed. +anytdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +anytdR r = r >+> anyR (anytdR r) + +-- | Apply a 'Rewrite' in a bottom-up manner, succeeding if they all succeed. +allbuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +allbuR r = allR (allbuR r) >>> r + +-- | Apply a 'Rewrite' in a bottom-up manner, succeeding if any succeed. +anybuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +anybuR r = anyR (anybuR r) >+> r + +-- | Apply a 'Rewrite' twice, in a top-down and bottom-up way, using one single tree traversal, +-- succeeding if they all succeed. +allduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +allduR r = r >>> allR (allduR r) >>> r + +-- | Apply a 'Rewrite' twice, in a top-down and bottom-up way, using one single tree traversal, +-- succeeding if any succeed. +anyduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +anyduR r = r >+> anyR (anyduR r) >+> r + +-- | Attempt to apply a 'Rewrite' in a top-down manner, prunning at successful rewrites. +tdpruneR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +tdpruneR r = r <+> anyR (tdpruneR r) + +-- | A fixed-point traveral, starting with the innermost term. +innermostR :: (Walker c m a, Generic a ~ a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a) +innermostR r = anybuR (r >>> tryR (innermostR r)) + +------------------------------------------------------------------------------- + +-- | A 'Path' is a list of 'Int's, where each 'Int' specifies which interesting child to descend to at each step. +type Path = [Int] + +-- | Construct a 'Lens' by following a 'Path'. +pathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a) +pathL = sequenceL . map childL + +-- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed. +exhaustPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a) +exhaustPathL [] = idL +exhaustPathL (n:ns) = tryL (childL n `composeL` exhaustPathL ns) + +-- | Repeat as many iterations of the 'Path' as possible. +repeatPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a) +repeatPathL p = tryL (pathL p `composeL` repeatPathL p) + +------------------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,2 @@ +> import Distribution.Simple +> main = defaultMain diff --git a/examples/Examples.hs b/examples/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Examples.hs @@ -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" + +--------------------------------------------------------------- diff --git a/examples/Expr/AST.hs b/examples/Expr/AST.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/AST.hs @@ -0,0 +1,31 @@ +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 (Seq c1 c2) = show c1 ++ " ; " ++ show c2 + show (Assign n e) = n ++ " := " ++ show e + +instance Show Expr where + 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" + +----------------------------------------------------------------- + +type Context = [(Name,Expr)] + +updateContext :: Cmd -> Context -> Context +updateContext (Seq c1 c2) = updateContext c2 . updateContext c1 +updateContext (Assign v e) = ((v,e):) + +----------------------------------------------------------------- diff --git a/examples/Expr/Examples.hs b/examples/Expr/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/Examples.hs @@ -0,0 +1,75 @@ +module Expr.Examples where + +import Language.KURE +import Language.KURE.Injection + +import Expr.AST +import Expr.Kure + +----------------------------------------------------------------- + +inlineR :: RewriteE Expr +inlineR = do (c, Var v) <- exposeT + constT (lookup v c) + +inlineGR :: RewriteE GenericExpr +inlineGR = promoteR inlineR + +----------------------------------------------------------------- + +expr1 :: Expr +expr1 = ESeq (Seq (Assign "m" (Lit 7)) + (Assign "n" (Add (Lit 1) (Lit 2))) + ) + (Add (Var "m") + (Var "n") + ) + +result1 :: Expr +result1 = ESeq (Seq (Assign "m" (Lit 7)) + (Assign "n" (Add (Lit 1) (Lit 2))) + ) + (Add (Lit 7) + (Add (Lit 1) (Lit 2)) + ) + +test1 :: Bool +test1 = apply (extractR (anytdR inlineGR)) [] expr1 == Just result1 + +expr2 :: Expr +expr2 = ESeq (Seq (Assign "m" (Lit 7)) + (Assign "n" (Add (Lit 1) (Lit 2))) + ) + (Add (Var "m") + (Var "x") + ) + +result2 :: Expr +result2 = ESeq (Seq (Assign "m" (Lit 7)) + (Assign "n" (Add (Lit 1) (Lit 2))) + ) + (Add (Lit 7) + (Var "x") + ) +test2 :: Bool +test2 = apply (extractR (anytdR inlineGR)) [] expr2 == Just result2 + +expr3 :: Expr +expr3 = ESeq (Assign "m" (Lit 7) + ) + (Add (Var "y") + (Var "x") + ) + +test3 :: Bool +test3 = apply (extractR (anytdR inlineGR)) [] expr3 == Nothing + +----------------------------------------------------------------- + +checkTests :: Bool +checkTests = and [ test1 + , test2 + , test3 + ] + +----------------------------------------------------------------- diff --git a/examples/Expr/Kure.hs b/examples/Expr/Kure.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/Kure.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-} + +module Expr.Kure where + +import Control.Applicative + +import Data.Monoid + +import Language.KURE +import Language.KURE.Injection +import Language.KURE.Utilities + +import Expr.AST + +--------------------------------------------------------------------------- + +-- NOTE: allT, allR and anyR have been defined to serve as examples, +-- but using the default instances would be fine (just slightly less efficient). + +--------------------------------------------------------------------------- + +type TranslateE a b = Translate Context Maybe a b +type RewriteE a = TranslateE a a + +--------------------------------------------------------------------------- + +data GenericExpr = GExpr Expr + | GCmd Cmd + +instance Term GenericExpr where + type Generic GenericExpr = GenericExpr + + numChildren (GExpr e) = numChildren e + numChildren (GCmd c) = numChildren c + +--------------------------------------------------------------------------- + +instance Walker Context Maybe GenericExpr where + + childL n = lens $ \ c g -> case g of + GExpr e -> childLgeneric n c e + GCmd cm -> childLgeneric n c cm + + allT t = translate $ \ c g -> case g of + GExpr e -> allTgeneric t c e + GCmd cm -> allTgeneric t c cm + + allR r = rewrite $ \ c g -> case g of + GExpr e -> allRgeneric r c e + GCmd cm -> allRgeneric r c cm + + anyR r = rewrite $ \ c g -> case g of + GExpr e -> anyRgeneric r c e + GCmd cm -> anyRgeneric r c cm + +--------------------------------------------------------------------------- + +instance Injection Expr GenericExpr where + inject = GExpr + + retract (GExpr e) = Just e + retract _ = Nothing + +instance Term Expr where + type Generic Expr = GenericExpr + + numChildren (Add _ _) = 2 + numChildren (ESeq _ _) = 2 + numChildren (Var _) = 0 + numChildren (Lit _) = 0 + + +instance Walker Context Maybe Expr where + childL 0 = addT exposeT idR (childL0of2 Add) + <+ eseqT exposeT idR (childL0of2 ESeq) + <+ missingChildL 0 + childL 1 = addT idR exposeT (childL1of2 Add) + <+ eseqT idR exposeT (childL1of2 ESeq) + <+ missingChildL 1 + childL n = missingChildL n + + allT t = varT (\ _ -> mempty) + <+ litT (\ _ -> mempty) + <+ addT (extractT t) (extractT t) mappend + <+ eseqT (extractT t) (extractT t) mappend + <+ fail "allT failed" + + allR r = varT Var + <+ litT Lit + <+ addAllR (extractR r) (extractR r) + <+ eseqAllR (extractR r) (extractR r) + <+ fail "allR failed" + + anyR r = addAnyR (extractR r) (extractR r) + <+ eseqAnyR (extractR r) (extractR r) + <+ fail "anyR failed" + +--------------------------------------------------------------------------- + +instance Injection Cmd GenericExpr where + inject = GCmd + + retract (GCmd c) = Just c + retract _ = Nothing + +instance Term Cmd where + type Generic Cmd = GenericExpr + + numChildren (Seq _ _) = 2 + numChildren (Assign _ _) = 2 + +instance Walker Context Maybe Cmd where + + childL 0 = seqT exposeT idR (childL0of2 Seq) + <+ assignT exposeT (childL1of2 Assign) + childL 1 = seqT idR exposeT (childL1of2 Seq) + <+ missingChildL 1 + childL n = missingChildL n + + allT t = seqT (extractT t) (extractT t) mappend + <+ assignT (extractT t) (\ _ -> id) + + allR r = seqAllR (extractR r) (extractR r) + <+ assignR (extractR r) + + anyR r = seqAnyR (extractR r) (extractR r) + <+ assignR (extractR r) + <+ fail "anyR failed" + +--------------------------------------------------------------------------- + +seqT' :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Cmd b +seqT' t1 t2 f = translate $ \ c cm -> case cm of + Seq cm1 cm2 -> f (apply t1 c cm1) (apply t2 (updateContext cm1 c) cm2) + _ -> fail "not a Seq" + +seqT :: TranslateE Cmd a1 -> TranslateE Cmd a2 -> (a1 -> a2 -> b) -> TranslateE Cmd b +seqT t1 t2 f = seqT' t1 t2 (liftA2 f) + +seqAllR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd +seqAllR r1 r2 = seqT r1 r2 Seq + +seqAnyR :: RewriteE Cmd -> RewriteE Cmd -> RewriteE Cmd +seqAnyR r1 r2 = seqT' (attemptR r1) (attemptR r2) (attemptAny2 Seq) + +--------------------------------------------------------------------------- + +assignT :: TranslateE Expr a -> (Name -> a -> b) -> TranslateE Cmd b +assignT t f = translate $ \ c cm -> case cm of + Assign n e -> f n <$> apply t c e + _ -> fail "not an Assign" + +assignR :: RewriteE Expr -> RewriteE Cmd +assignR r = assignT r Assign + +--------------------------------------------------------------------------- + +varT :: (Name -> b) -> TranslateE Expr b +varT f = contextfreeT $ \ e -> case e of + Var v -> pure (f v) + _ -> fail "not a Var" + +--------------------------------------------------------------------------- + +litT :: (Int -> b) -> TranslateE Expr b +litT f = contextfreeT $ \ e -> case e of + Lit v -> pure (f v) + _ -> fail "not a Lit" + +--------------------------------------------------------------------------- + +addT' :: TranslateE Expr a1 -> TranslateE Expr a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Expr b +addT' t1 t2 f = translate $ \ c e -> case e of + Add e1 e2 -> f (apply t1 c e1) (apply t2 c e2) + _ -> fail "not an Add" + +addT :: TranslateE Expr a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b +addT t1 t2 f = addT' t1 t2 (liftA2 f) + +addAllR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr +addAllR r1 r2 = addT r1 r2 Add + +addAnyR :: RewriteE Expr -> RewriteE Expr -> RewriteE Expr +addAnyR r1 r2 = addT' (attemptR r1) (attemptR r2) (attemptAny2 Add) + +--------------------------------------------------------------------------- + +eseqT' :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (Maybe a1 -> Maybe a2 -> Maybe b) -> TranslateE Expr b +eseqT' t1 t2 f = translate $ \ c e -> case e of + ESeq cm e1 -> f (apply t1 c cm) (apply t2 (updateContext cm c) e1) + _ -> fail "not an ESeq" + +eseqT :: TranslateE Cmd a1 -> TranslateE Expr a2 -> (a1 -> a2 -> b) -> TranslateE Expr b +eseqT t1 t2 f = eseqT' t1 t2 (liftA2 f) + +eseqAllR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr +eseqAllR r1 r2 = eseqT r1 r2 ESeq + +eseqAnyR :: RewriteE Cmd -> RewriteE Expr -> RewriteE Expr +eseqAnyR r1 r2 = eseqT' (attemptR r1) (attemptR r2) (attemptAny2 ESeq) + +--------------------------------------------------------------------------- diff --git a/examples/Fib/AST.hs b/examples/Fib/AST.hs new file mode 100644 --- /dev/null +++ b/examples/Fib/AST.hs @@ -0,0 +1,18 @@ +module Fib.AST 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" diff --git a/examples/Fib/Examples.hs b/examples/Fib/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Fib/Examples.hs @@ -0,0 +1,122 @@ +module Fib.Examples where + +import Language.KURE + +import Fib.AST +import Fib.Kure + +----------------------------------------------------------------------- + +applyFib :: RewriteA -> Arith -> Maybe Arith +applyFib e = apply e () + +----------------------------------------------------------------------- + +-- | Apply the definition of the fibonacci function once. +-- Requires the argument to Fib to be a Literal. +fibLitR :: RewriteA +fibLitR = 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 = do Add (Lit m) (Lit n) <- idR + return (Lit (m + n)) + +-- | Compute the subtraction of two literals. +subLitR :: RewriteA +subLitR = do Sub (Lit m) (Lit n) <- idR + return (Lit (m - n)) + +----------------------------------------------------------------------- + +arithR :: RewriteA +arithR = addLitR >+> subLitR + +anyAddR :: RewriteA +anyAddR = anybuR addLitR + +anySubR :: RewriteA +anySubR = anybuR subLitR + +anyArithR :: RewriteA +anyArithR = anybuR 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 anyAddR expr1 + == + Just (10 - 5) + +test1b :: Bool +test1b = applyFib anySubR expr1 + == + Nothing + +test1c :: Bool +test1c = applyFib anyArithR expr1 + == + Just 5 + +test1d :: Bool +test1d = applyFib evalR expr1 + == + Just 5 + +test2a :: Bool +test2a = applyFib fibLitR expr2 + == + Just ((Fib (8 - 1)) + (Fib (8 - 2))) + +test2b :: Bool +test2b = applyFib (anytdR fibLitR) expr2 + == + Just ((Fib (8 - 1)) + (Fib (8 - 2))) + +test2c :: Bool +test2c = applyFib evalR expr2 + == + Just 21 + +test3a :: Bool +test3a = applyFib anyArithR expr3 + == + Just (100 - (Fib 10)) + +test3b :: Bool +test3b = applyFib (anyArithR >+> anyR fibLitR) expr3 + == + Just (100 - ((Fib (10 - 1)) + (Fib (10 - 2)))) + +test3c :: Bool +test3c = applyFib evalR expr3 + == + Just 45 + +----------------------------------------------------------------------- + +checkTests :: Bool +checkTests = and [ test1a, test1b, test1c, test1d + , test2a, test2b, test2c, test3a + , test3b, test3c + ] + +----------------------------------------------------------------------- diff --git a/examples/Fib/Kure.hs b/examples/Fib/Kure.hs new file mode 100644 --- /dev/null +++ b/examples/Fib/Kure.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-} + +module Fib.Kure where + +import Control.Applicative + +import Language.KURE +import Fib.AST + +-------------------------------------------------------------------------------------- + +-- | For this simple example, the context is always empty and 'Translate' always operates on 'Arith' +type TranslateA b = Translate () Maybe Arith b +type RewriteA = TranslateA Arith + +-------------------------------------------------------------------------------------- + +instance Term Arith where + type Generic Arith = Arith + + numChildren (Lit _) = 0 + numChildren (Add _ _) = 2 + numChildren (Sub _ _) = 2 + numChildren (Fib _) = 1 + +instance Walker () Maybe Arith where + + childL n = lens $ \ c e -> case e of + Lit _ -> empty + Add e1 e2 -> case n of + 0 -> pure ((c,e1), \ e1' -> pure (Add e1' e2)) + 1 -> pure ((c,e2), \ e2' -> pure (Add e1 e2')) + _ -> empty + Sub e1 e2 -> case n of + 0 -> pure ((c,e1), \ e1' -> pure (Sub e1' e2)) + 1 -> pure ((c,e2), \ e2' -> pure (Sub e1 e2')) + _ -> empty + Fib e1 -> case n of + 0 -> pure ((c,e1), \ e1' -> pure (Fib e1')) + _ -> empty + +-------------------------------------------------------------------------------------- diff --git a/examples/Lam/AST.hs b/examples/Lam/AST.hs new file mode 100644 --- /dev/null +++ b/examples/Lam/AST.hs @@ -0,0 +1,67 @@ +module Lam.AST where + +import Control.Applicative +import Control.Monad + +------------------------------------------------------------------------------- + +import Control.Arrow (second) +import Language.KURE.Combinators (result) + +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 ++ ")" + +------------------------------------------------------------------------------- + +type Context = [Name] -- bound variable names + +newtype LamM a = LamM {expM :: Int -> (Int, Either String a)} + +runLamM :: LamM a -> Either String a +runLamM m = snd (expM m 0) + +instance Functor LamM where + fmap f (LamM m) = LamM ((result.second.fmap) f m) + +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) -> expM (gg a) n' + fail msg = LamM (\ n -> (n, Left msg)) + +instance MonadPlus LamM where + mzero = fail "" + (LamM f) `mplus` (LamM g) = LamM $ \ n -> case f n of + (n', Left _) -> g n' + (n', Right a) -> (n', Right a) + +instance Applicative LamM where + pure = return + (<*>) = ap + +instance Alternative LamM where + empty = mzero + (<|>) = mplus + +------------------------------------------------------------------------------- + +suggestName :: LamM Name +suggestName = LamM (\n -> ((n+1), Right (show n))) + +freshName :: Context -> LamM Name +freshName c = do n <- suggestName + if n `elem` c + then freshName c + else return n + +------------------------------------------------------------------------------- diff --git a/examples/Lam/Examples.hs b/examples/Lam/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Lam/Examples.hs @@ -0,0 +1,216 @@ +module Lam.Examples where + +import Language.KURE + +import Lam.AST +import Lam.Kure + +import Data.List (nub) +import Control.Monad (guard) +import Control.Arrow + +------------------------------------------------------------------------ + +freeVarsT :: TranslateExp [Name] +freeVarsT = fmap nub $ crushbuT $ do (c, Var v) <- exposeT + guard (v `notElem` c) + return [v] + +freeVars :: Exp -> [Name] +freeVars = either error id . applyExp freeVarsT + +-- Only works for lambdas, fails for all others +alphaLam :: [Name] -> RewriteExp +alphaLam frees = do Lam v e <- idR + v' <- constT $ freshName $ frees ++ v : freeVars e + lamT (tryR $ substExp v (Var v')) (\ _ -> Lam v') + +substExp :: Name -> Exp -> RewriteExp +substExp 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 + guard (n /= v) -- Rule 3 + guard (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 :: RewriteExp +beta_reduce = do App (Lam v _) e2 <- idR + focusT (pathL [0,0]) (tryR $ substExp v e2) + +eta_expand :: RewriteExp +eta_expand = rewrite $ \ c f -> do v <- freshName c + return $ Lam v (App f (Var v)) + +eta_reduce :: RewriteExp +eta_reduce = contextfreeT $ \ e -> case e of + Lam v1 (App f (Var v2)) -> do guardFail (v1 == v2) $ "Cannot eta-reduce, " ++ v1 ++ " /= " ++ v2 + return f + _ -> fail "Cannot eta-reduce, not lambda-app-var." + +-- This might not actually be normal order evaluation +-- Contact the KURE maintainer if you can correct this definition. +normal_order_eval :: RewriteExp +normal_order_eval = anytdR (repeatR beta_reduce) + +-- This might not actually be applicative order evaluation +-- Contact the KURE maintainer if you can correct this definition. +applicative_order_eval :: RewriteExp +applicative_order_eval = innermostR beta_reduce + +------------------------------------------------------------------------ + +type LamTest = (RewriteExp,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 + +------------------------------------------------------------------------ diff --git a/examples/Lam/Kure.hs b/examples/Lam/Kure.hs new file mode 100644 --- /dev/null +++ b/examples/Lam/Kure.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-} + +module Lam.Kure where + +import Control.Applicative + +import Language.KURE +import Language.KURE.Utilities + +import Lam.AST + +------------------------------------------------------------------------------- + +type TranslateExp b = Translate Context LamM Exp b +type RewriteExp = TranslateExp Exp + +applyExp :: TranslateExp b -> Exp -> Either String b +applyExp f = runLamM . apply f [] + +------------------------------------------------------------------------------- + +instance Term Exp where + type Generic Exp = Exp -- Exp is its own Generic + + numChildren (Var _) = 0 + numChildren (Lam _ _) = 1 + numChildren (App _ _) = 2 + +instance Walker Context LamM Exp where + childL n = case n of + 0 -> appT exposeT idR (childL0of2 App) + <+ lamT exposeT (childL1of2 Lam) + + 1 -> appT idR exposeT (childL1of2 App) + + _ -> missingChildL n + +------------------------------------------------------------------------------- + +-- | Congruence combinators. +-- Using these ensures that the context is updated consistantly. + +varT :: (Name -> b) -> TranslateExp b +varT f = contextfreeT $ \ e -> case e of + Var n -> return (f n) + _ -> fail "no match for Var" + +------------------------------------------------------------------------------- + +lamT :: TranslateExp a -> (Name -> a -> b) -> TranslateExp b +lamT t f = translate $ \ c e -> case e of + Lam v e1 -> f v <$> apply t (v:c) e1 + _ -> fail "no match for Lam" + +lamR :: RewriteExp -> RewriteExp +lamR r = lamT r Lam + +------------------------------------------------------------------------------- + +appT' :: TranslateExp a1 -> TranslateExp a2 -> (LamM a1 -> LamM a2 -> LamM b) -> TranslateExp b +appT' t1 t2 f = translate $ \ c e -> case e of + App e1 e2 -> f (apply t1 c e1) (apply t2 c e2) + _ -> fail "no match for App" + +appT :: TranslateExp a1 -> TranslateExp a2 -> (a1 -> a2 -> b) -> TranslateExp b +appT t1 t2 f = appT' t1 t2 (liftA2 f) + +appAllR :: RewriteExp -> RewriteExp -> RewriteExp +appAllR r1 r2 = appT r1 r2 App + +appAnyR :: RewriteExp -> RewriteExp -> RewriteExp +appAnyR r1 r2 = appT' (attemptR r1) (attemptR r2) (attemptAny2 App) + +------------------------------------------------------------------------------- diff --git a/kure.cabal b/kure.cabal --- a/kure.cabal +++ b/kure.cabal @@ -1,31 +1,49 @@ Name: kure -Version: 0.3.1 +Version: 2.0.0 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 DSL for strategic rewriting. + KURE shares concepts with Stratego, but unlike Stratego, KURE is strongly typed. + KURE is similar to StrategyLib, but has a lightweight generic traversal mechanism using type families + rather than SYB. + The basic transformation functionality can be found in "Language.KURE.Translate", + and the traversal functionality can be found in "Language.KURE.Walker". + Several basic examples of using KURE are provided in the source-code bundle. + For a larger example, see the HERMIT package. Category: Language License: BSD3 License-file: LICENSE -Author: Andy Gill -Maintainer: Andy Gill -Copyright: (c) 2006-2009 Andy Gill -Homepage: http://ittc.ku.edu/~andygill/kure.php -Stability: alpha +Author: Neil Sculthorpe and Andy Gill +Maintainer: Neil Sculthorpe +Copyright: (c) 2012 The University of Kansas +Homepage: http://www.ittc.ku.edu/csdl/fpg/Tools/KURE +Stability: beta build-type: Simple Cabal-Version: >= 1.6 +Extra-Source-Files: + examples/Examples.hs + examples/Fib/AST.hs + examples/Fib/Kure.hs + examples/Fib/Examples.hs + examples/Lam/AST.hs + examples/Lam/Kure.hs + examples/Lam/Examples.hs + examples/Expr/AST.hs + examples/Expr/Kure.hs + examples/Expr/Examples.hs Library - Build-Depends: base + Build-Depends: base >= 4.5 && < 5 + 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.Combinators + Language.KURE.Translate + Language.KURE.Injection + Language.KURE.Walker + Language.KURE.Utilities + + + +