diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,1 @@ +See www.sourceforge.net/Strafunski diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,30 @@ +This a pure source distribution of Strafunski's StrategyLib. + +Everything should work out of the box. + +You can use the library if you have hugs or ghc installed. If you +want to generate Term instances for Datatypes, you will need +DrIFT. For the examples included in the distribution, the generated +files are however shipped, so that you don't need DrIFT if you just +want to play with distribution. + +The distribution was tested with the following configuration: + +- ghci/ghc 6.2 +- ghci/ghc 6.0.1 (works too but not eariler versions) +- hugs version November 2002 (don't use earlier versions) +- DrIFT 2.0.1 (don't use earlier versions) +- gmake 3.79.1 (most versions should do) +- examples/twosorts-deriving needs an unreleased GHC version + +All these programs are expected to be in your path. + +Run "gmake check" to test the distribution if you like. There are also +more specific targets for running examples. For example, the most +simple example, i.e., "twosorts-drift-default" is ran with hugs as +follows: + +> cd examples/twosorts-drift-default +> gmake test-hugs + +For all other information see the file README. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ + +StrategyLib --- a library for generic programming with functional strategies + +README file + +Table of contents + +- Cross references (files with further information) +- Subdirectories of the source distribution +- Prerequisites for using the library and running examples +- Checking the installation (just do a "gmake check") +- Targets used by Makefile system +- Supported models of functional strategies +- + +------------------------------------------------------------------------------ + + +Cross references +---------------- + +AUTHORS --- authors of Strafunski +COPYING --- BSD-style copyright +INTALL --- recommeneded versions of hugs/ghc/ghci/DrIFT +VERSION --- version of StrategyLib +ChangeLog --- changes compared to previous version +TODO --- issues to be addressed in the future + + +------------------------------------------------------------------------------ + + +Subdirectories of the source distribution +----------------------------------------- + +library --- implementation of functional strategies and StrategLib's themes +models --- different models of functional strategies +scripts --- reusable scripts (mainly includes for Makefiles) +examples --- examples of using functional strategies + + +------------------------------------------------------------------------------ + + +Prerequisites for using the library and running examples +-------------------------------------------------------- + +Either ghc or hugs or both, and maybe DrIFT. +See the file INSTALL for details. + + +------------------------------------------------------------------------------ + + +Checking the installation +------------------------- + +Just type in "gmake check" which provides you with a list of options +to check the distribution in different ways. The options differ +regarding the used Haskell implementations and regarding the fact +whether derived modules are to be regenerated with DrIFT or the +shipped versions will be used as is. + + +------------------------------------------------------------------------------- + + +Targets used by Makefile system +------------------------------- + +You don't need to "make" anything since this is a source distribution, +but there are some make targets to run examples and do other things. +In applications of StrategyLib, one is encouraged to reuse some includes +for Makefiles as provided in subdirectory "scripts". + + +Targets in examples/*/Makefiles: + + run-hugs --- run Main.hs with hugs + run-ghci --- run Main.hs with ghci + run-ghc --- run Main.hs with ghc + derive --- run DrIFT if needed + + +Recursive clean targets: + + clean --- remove backup files, object code, etc. + very-clean --- also remove modules generated by DrIFT + + +Targets in the top-level Makefile: + + check --- list detailed check options + dist --- build a distribution (to be implemented) + + +------------------------------------------------------------------------------- + + +Supported models of functional strategies +----------------------------------------- + +We have played with quite a few models, and most of them are somewhat +supported by DrIFT, but for simplicity we only exercise two models in +the present distribution; see subdirectory "models": + +- drift-default: a model based on a specific universal term representation +- deriving: a model based on GHC's support for the Typeable/Data classes + +Most subdirectories of ${StrategyLib}/examples assume the +"drift-default" model. In fact, we only demonstrate the difference for +the two models by having a "twosorts-drift-default" vs. a +"twosorts-deriving" example. + + +------------------------------------------------------------------------------- + + +Examples +-------- + +Examples are hosted in subdirectory examples. + +two-sorts-drift-default --- the most trivial example; good for studying +two-sorts-derving --- a variation requiring GHC's deriving support +little-lambda --- a trivial example of language processing +joos-padl02 --- refactoring for a Java-subset (see PADL'02 paper) +joos-rule02 --- refactoring for a Java-subset (see RULE'02 paper) +haskell --- transformation of Haskell itself + + +------------------------------------------------------------------------------- + + +Links +----- + +- DrIFT --- http://repetae.net/john/computer/haskell/DrIFT/ +- Strafunski --- http://www.cs.vu.nl/Strafunski/ + http://strafunski.sourceforge.net/ + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/StrategyLib.cabal b/StrategyLib.cabal new file mode 100644 --- /dev/null +++ b/StrategyLib.cabal @@ -0,0 +1,31 @@ +Name: StrategyLib +Version: 4.0.0.0 +Description: attempt to convert Strafunski's StrategyLib to a heirarchical library +Homepage: http://naesten.dyndns.org:8080/repos/StrategyLib +Category: Generics +Maintainer: Samuel Bronson +Build-depends: base, mtl +Stability: pre-alpha +extra-source-files: COPYING INSTALL README TODO +hs-source-dirs: library models/deriving +exposed-modules: + Control.Monad.Maybe, Control.Monad.Run, + Data.Generics.Strafunski.StrategyLib.StrategyPrimitives, + Data.Generics.Strafunski.StrategyLib.TermRep, + Data.Generics.Strafunski.StrategyLib.ChaseImports, + Data.Generics.Strafunski.StrategyLib.ContainerTheme, + Data.Generics.Strafunski.StrategyLib.EffectTheme, + Data.Generics.Strafunski.StrategyLib.FixpointTheme, + Data.Generics.Strafunski.StrategyLib.FlowTheme, + Data.Generics.Strafunski.StrategyLib.KeyholeTheme, + Data.Generics.Strafunski.StrategyLib.MetricsTheme, + Data.Generics.Strafunski.StrategyLib.MonadicFunctions, +-- MoreMonoids, + Data.Generics.Strafunski.StrategyLib.NameTheme, + Data.Generics.Strafunski.StrategyLib.OverloadingTheme, + Data.Generics.Strafunski.StrategyLib.PathTheme, + Data.Generics.Strafunski.StrategyLib.RefactoringTheme, + Data.Generics.Strafunski.StrategyLib.StrategyInfix, + Data.Generics.Strafunski.StrategyLib.StrategyPrelude, + Data.Generics.Strafunski.StrategyLib.TraversalTheme + diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,2 @@ +- Omitted some examples compared to V3; more could still be added. + diff --git a/library/Control/Monad/Maybe.hs b/library/Control/Monad/Maybe.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/Maybe.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +------------------------------------------------------------------------------ +-- | +-- Author : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module introduces the MaybeT monad transformer. +-- It is basically a simplification of the ErrorT monad transformer. + +------------------------------------------------------------------------------ + +module Control.Monad.Maybe ( + + MaybeT(..) + +) where + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State +--import Control.Monad.RWS +import Control.Monad.Cont +import Control.Monad.Error + +------------------------------------------------------------------------------ + +-- | The monad transformer 'MaybeT'. +newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } + +instance (Monad m) => Functor (MaybeT m) where + fmap f m = MaybeT $ do + a <- runMaybeT m + case a of + Nothing -> return (Nothing) + Just r -> return (Just (f r)) + +instance (Monad m) => Monad (MaybeT m) where + return a = MaybeT $ return (Just a) + m >>= k = MaybeT $ do + a <- runMaybeT m + case a of + Nothing -> return (Nothing) + Just r -> runMaybeT (k r) + fail msg = MaybeT $ return (Nothing) + +instance (Monad m) => MonadPlus (MaybeT m) where + mzero = MaybeT $ return (Nothing) + m `mplus` n = MaybeT $ do + a <- runMaybeT m + case a of + Nothing -> runMaybeT n + Just r -> return (Just r) + +instance (MonadFix m) => MonadFix (MaybeT m) where + mfix f = MaybeT $ mfix $ \a -> runMaybeT $ f $ case a of + Just r -> r + _ -> error "empty mfix argument" + +{- +instance (Monad m) => MonadError e (MaybeT m) where + throwError l = MaybeT $ return (Nothing) + m `catchError` h = MaybeT $ do + a <- runMaybeT m + case a of + Nothing -> runMaybeT (h l) + Just r -> return (Just r) +-} + +instance MonadTrans (MaybeT) where + lift m = MaybeT $ do + a <- m + return (Just a) + +instance (MonadIO m) => MonadIO (MaybeT m) where + liftIO = lift . liftIO + +instance (MonadReader r m) => MonadReader r (MaybeT m) where + ask = lift ask + local f m = MaybeT $ local f (runMaybeT m) + +instance (MonadWriter w m) => MonadWriter w (MaybeT m) where + tell = lift . tell + listen m = MaybeT $ do + (a, w) <- listen (runMaybeT m) + return $ case a of + Nothing -> Nothing + Just r -> Just (r, w) + pass m = MaybeT $ pass $ do + a <- runMaybeT m + return $ case a of + Nothing -> (Nothing, id) + Just (r, f) -> (Just r, f) + +instance (MonadState s m) => MonadState s (MaybeT m) where + get = lift get + put = lift . put + +instance (MonadCont m) => MonadCont (MaybeT m) where + callCC f = MaybeT $ + callCC $ \c -> + runMaybeT (f (\a -> MaybeT $ c (Just a))) + +------------------------------------------------------------------------------ diff --git a/library/Control/Monad/Run.hs b/library/Control/Monad/Run.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/Run.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +------------------------------------------------------------------------------ +-- | +-- Author : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- provides non-strategic functionality for running monads and unlifting +-- monad transformers. In a sense, this is dual to the 'return' and 'lift' +-- functionality of the 'Monad' and 'MonadTrans' classes. +-- +------------------------------------------------------------------------------ + +module Control.Monad.Run where + +import Control.Monad.Trans +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.List +import Control.Monad.Maybe +import Control.Monad.Error +--import Foreign (unsafePerformIO) -- for running IO monads + + +------------------------------------------------------------------------------ +-- * Monad algebras + +-- | The algebra for the partiality effect of 'Maybe' and 'MaybeT'. +data MaybeAlg a b = MaybeAlg { nothing :: b, just :: a -> b } + +-- | The algebra for the error effect of 'Either' and 'ErrorT'. +data ErrorAlg e a b = ErrorAlg { left :: e -> b, right :: a -> b } + +-- | The algebra for the non-determinacy effect of '[]' and 'ListT'. +data ListAlg a b = ListAlg { nil :: b, cons :: a -> b -> b } + +-- | The algebra for the state effect of 'State' and 'StateT'. +data StateAlg s a b = StateAlg { first :: s, -- ^ initial state + next :: (a,s) -> b -- ^ state transformer + } + +--evalStateAlg s = StateAlg (\f -> fst (f s)) +--execStateAlg s = StateAlg (\f -> snd (f s)) + + +------------------------------------------------------------------------------ +-- * Running monads + +-- | The class of monads for which a 'run' function is defined that +-- executes the computation of the monad. +class MonadRun s m | m -> s where + -- | The overloaded function run takes as first argument an "algebra" which + -- captures the ingredients necessary to run the particular monad at hand. + -- This algebra is parameterized with the domain and co-domain of run. + run :: s a b -> m a -> b + +-- | Running the 'Identity' monad. +-- The algebra for the 'Identity' monad is a unary function. +instance MonadRun (->) Identity where + run alg = alg . runIdentity + +-- | Running the 'Maybe' monad. +instance MonadRun MaybeAlg Maybe where + run alg = maybe (nothing alg) (just alg) + +-- | Running the error monad. +instance MonadRun (ErrorAlg e) (Either e) where + run alg = either (left alg) (right alg) + +-- | Running the list monad. +instance MonadRun ListAlg [] where + run alg = foldr (cons alg) (nil alg) + +-- | Running the 'State' monad. +instance MonadRun (StateAlg s) (State s) where + run alg = \ma -> next alg (runState ma (first alg)) + +{- +-- | Running the 'IO' monad. +-- Note: uses 'unsafePerformIO'! +instance MonadRun (->) IO where + run alg = alg . unsafePerformIO +-} + +-- | Exchange one monad by another. +-- This function runs one monad, and puts its value in another. This is +-- basically a monadic version of the 'run' function itself. Note that the two +-- monads are unrelated, so none of the effects of the incoming monad are +-- transferred to the result monad. +mrun :: (MonadRun s m ,Monad m') => s a b -> m a -> m' b +mrun alg ma = return (run alg ma) + + +------------------------------------------------------------------------------ +-- * Unlifting monad transformers + +-- | Just as a base monad can be run to remove the monad, so can a transformed +-- monad be unlifted to remove the transformer and obtain the original monad. +class MonadUnTrans s t | t -> s where + -- | The overloaded function 'unlift' for monad transformers takes as first + -- argument an "algebra" just like the run function for base monads. For + -- each monad transformer, the same algebra is used as for the base monad + -- of which the transformer is the parameterized variant. + unlift :: Monad m => s a b -> t m a -> m b + +-- | Unlifting the list monad transformer. +instance MonadUnTrans ListAlg ListT where + unlift alg ma = do as <- runListT ma + return (foldr (cons alg) (nil alg) as) + +-- | Unlifting the partiality monad transformer. +instance MonadUnTrans MaybeAlg MaybeT where + unlift alg ma = do ea <- runMaybeT ma + return (maybe (nothing alg) (just alg) ea) + +-- | Unlifting the error monad transformer. +instance MonadUnTrans (ErrorAlg e) (ErrorT e) where + unlift alg ma = do ea <- runErrorT ma + return (either (left alg) (right alg) ea) + +-- | Unlifting the state monad transformer +instance MonadUnTrans (StateAlg s) (StateT s) where + unlift alg ma = do as <- runStateT ma (first alg) + return (next alg as) + +-- * Monadic choice combinators that confine the partiality effect + +-- Result of pair programming with Alberto Pardo + +-- ** Monadic choice + +-- | Monadic choice combinator that confines the partiality effect to +-- the first argument. This is a variation on 'mplus' which allows +-- the partiality effect to spread to both arguments and to the result. +mplus' :: (Monad m, MonadUnTrans MaybeAlg t) + => t m b -> m b -> m b +m1 `mplus'` m2 = unlift (MaybeAlg m2 return) m1 >>= id + +-- | Monadic choice combinator. Generalization of 'mplus'' that takes a list +-- of choice arguments rather than a single one. +mswitch :: (Monad m, MonadUnTrans MaybeAlg t) + => [t m b] -- ^ choice branches + -> m b -- ^ otherwise + -> m b -- ^ result +mswitch [] m = m +mswitch (tm:tms) m = tm `mplus'` (mswitch tms m) + +-- | Specialization of 'mswitch' for MaybeT. +mayswitch :: (Monad m) => [MaybeT m b] -> m b -> m b +mayswitch tms m = (foldr mplus mzero tms) `mplus'` m + + +-- ** Monadic function choice + +-- | Monadic function choice combinator that confines the partiality effect +-- to the first argument. This is a variation on 'mchoice' which +-- allows the partiality effect to spread to both arguments and to the +-- result. +mchoice' :: (Monad m, MonadUnTrans MaybeAlg t) + => (a -> t m b) -> (a -> m b) -> a -> m b +f `mchoice'` g = \a -> do ea <- unlift (MaybeAlg Nothing Just) (f a) + maybe (g a) (return) ea + +-- | Monadic function choice combinator. Generalization of 'mchoice'' that +-- takes a list of choice arguments rather than a single one. +mchoices :: (Monad m, MonadUnTrans MaybeAlg t, MonadPlus (t m)) + => [a -> t m b] -> (a -> m b) -> a -> m b +mchoices fs f = \a -> mswitch' (map (\f -> f a) fs) (f a) + + +-- ** Implementation variants + +-- | Implementation variant of 'mswitch' in terms of foldr. +mswitch0 :: (Monad m, MonadUnTrans MaybeAlg t) + => [t m b] -> m b -> m b +mswitch0 tms m = foldr mplus' m tms + +-- | Implementation variant of 'mswitch' with 'mplus'' expanded: +mswitch1 :: (Monad m, MonadUnTrans MaybeAlg t) + => [t m b] -> m b -> m b +mswitch1 [] m = m +mswitch1 (tm:tms) m = unlift (MaybeAlg (mswitch1 tms m) return) tm >>= id + +-- | Implementation variant of 'mswitch' where the unlift is postponed +-- to the very end. +mswitch' :: (Monad m, MonadUnTrans MaybeAlg t, + MonadPlus (t m)) + => [t m b] -> m b -> m b +mswitch' tms m = (foldr mplus mzero tms) `mplus'` m + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/ChaseImports.hs b/library/Data/Generics/Strafunski/StrategyLib/ChaseImports.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/ChaseImports.hs @@ -0,0 +1,132 @@ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- defines a generic algorithm for import chasing. This algorithm is not +-- strategic in nature itself, but usually it will be instantiated with +-- strategic functions for a particular object language. + +-----------------------------------------------------------------------------} + +module Data.Generics.Strafunski.StrategyLib.ChaseImports ( +-- * Type synonym + ChaseName, +-- * Generic import chasing + chaseWith, + chaseFile, findFile +) where + +import Control.Monad +import System.Directory +import Control.Monad.Error () -- This import gives us (MonadPlus IO) !! +import System.IO +import Control.Exception (try) + + +------------------------------------------------------------------------------ +-- * Type synonym + +-- | The type of names of chaseable things. Synonym of 'String'. +type ChaseName = String + + + +------------------------------------------------------------------------------ +-- * Generic import chasing + +-- | A generic import chasing function. The type of the final result is a +-- parameter, which will usually be instantiated to a list of parsed +-- modules. +chaseWith + :: [FilePath] -- ^ path (list of directories to search) + -> [ChaseName] -- ^ todo (list of modules still to find) + -> [ChaseName] -- ^ done (list of modules already found) + -> accu -- ^ initial (start value of accumulator) + -> ([FilePath] -> ChaseName -> IO (Either cu String)) + -- ^ parse (function that attempt to find and parse a module) + -> (cu -> [ChaseName]) -- ^ imports (function that extracts imports from + -- a parse result) + -> (ChaseName -> [ChaseName] -> cu -> accu -> IO accu) + -- ^ on module (function that computes a new + -- accumulator from a parse result) + -> (ChaseName -> accu -> IO accu) + -- ^ on missing (function that computes a new + -- accumulator value when parsing failed) + -> IO accu -- ^ result (accumulated value) +chaseWith dirs todo done accu parseFile getImports onModule onMissing + = chase todo done accu + where + chase [] done accu + = do errLn "Import chasing complete." + return accu + chase (m:ms) done accu + | m `elem` done = chase ms done accu + | otherwise = processFile `mplus` skipFile + where + processFile + = do parse_result <- parseFile dirs m + case parse_result of + Left pin + -> let is = getImports pin + in do accu' <- onModule m is pin accu + chase (ms++is) (m:done) accu' + Right msg + -> do errLn ("Failed to parse "++m++": "++msg) + accu' <- onMissing m accu + chase ms (m:done) accu' + skipFile + = do errLn ("Could not find module "++m++": skipping.") + accu' <- onMissing m accu + chase ms (m:done) accu' + + + +-- | Read a file from a number of possible directories, given a +-- base name and a list of possible extensions. Returns the content +-- of the file it found. +chaseFile :: [FilePath] -- ^ path (directories to search) + -> String -- ^ base name + -> [String] -- ^ possible extensions + -> IO String -- ^ contents of file +chaseFile dirs basename exts + = do results <- mapM tryReadFile fnames + case dropWhile hasFailed results of + ((Right (fc,fn)):_) + -> errLn ("Read file: "++fn) >> return fc + _ -> errLn ("Could not find file: "++basename) >> mzero + where + fnames = [d++'/':basename++'.':e | d <- dirs, e <- exts] + hasFailed (Left _) = True + hasFailed _ = False + tryReadFile fn = try ( readFile fn >>= \fc -> return (fc,fn) ) + + +-- | Find a file in a number of possible directories, given a +-- base name and a list of possible extensions. Returns the full +-- name of the file it found. +findFile :: [FilePath] -- ^ path (directories to search) + -> String -- ^ base name + -> [String] -- ^ possible extensions + -> IO FilePath -- ^ contents of file +findFile dirs basename exts + = do existingFileNames <- filterM doesFileExist fnames + case existingFileNames of + (fn:_) + -> errLn ("Found file: "++fn) >> return fn + _ -> errLn ("Could not find file: "++basename) >> mzero + where + fnames = [d++'/':basename++'.':e | d <- dirs, e <- exts] + + + +------------------------------------------------------------------------------ +-- * Progress and error messages + +-- | Helper function for reporting errors and progress to stderr +errLn str = hPutStrLn stderr str + + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/ContainerTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/ContainerTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/ContainerTheme.hs @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- provides combinators which allow one to use strategies to construct +-- generic containers. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.ContainerTheme ( + module Data.Generics.Strafunski.StrategyLib.ContainerTheme, +) where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Control.Monad +import Data.Monoid + +------------------------------------------------------------------------------ +-- * Pointwise function update + +-- | Pointwise modification of monomorphic functions +modify :: Eq x => (x -> y) -> x -> y -> (x -> y) +modify f x y = \x' -> if x == x' then y else f x' + +-- | Pointwise modification of type-preserving strategies +modifyTP :: (MonadPlus m, Eq t, Term t) => TP m -> t -> m t -> TP m +modifyTP f t = adhocTP f . modify (applyTP f) t + +-- | Pointwise modification of type-unifying strategies +modifyTU :: (MonadPlus m, Eq t, Term t) => TU a m -> t -> m a -> TU a m +modifyTU f t = adhocTU f . modify (applyTU f) t + +------------------------------------------------------------------------------ +-- * Generic Set (not observable) + +-- | Type of generic sets +type GSet = TU () Maybe + +-- | Empty generic set. +emptyGSet :: GSet +emptyGSet = failTU + +-- | Completely filled generic set +fullGSet :: GSet +fullGSet = constTU mempty + +-- | Add an element to a generic set +addGSet :: (Eq t, Term t) => t -> GSet -> GSet +addGSet t s = modifyTU s t (return mempty) + +-- | Remove an element from a generic set +removeGSet :: (Eq t, Term t) => t -> GSet -> GSet +removeGSet t s = modifyTU s t mzero + +-- | Test whether a given element is contained in a generic set +containsGSet :: (Eq t, Term t) => t -> GSet -> Bool +containsGSet t s= maybe False (const True) (applyTU s t) + +------------------------------------------------------------------------------ +-- * Generic Map (not observable) + +-- | Type of generic maps +type GMap value = TU value Maybe + +-- | Empty generic map +emptyGMap :: GMap v +emptyGMap = failTU + +-- | Remove an element from a generic map (my key) +removeGMap :: (Eq t, Term t) => t -> GMap v -> GMap v +removeGMap t s = modifyTU s t mzero + +-- | Test whether an element with given key is contained in a generic map +containsGMap :: (Eq t, Term t) => t -> GMap v -> Bool +containsGMap t s= maybe False (const True) (applyTU s t) + +-- | Add an entry with given key and value to a generic map +putGMap :: (Eq t, Term t) => t -> v -> GMap v -> GMap v +putGMap t v s = modifyTU s t (return v) + +-- | Obtain the value for a given key from a generic map +getGMap :: (Eq t, Term t) => t -> GMap v -> Maybe v +getGMap t s = applyTU s t + + +------------------------------------------------------------------------------ +--- Generic List (observable per type) --------------------------------------- + +type GList = (Integer -> TP Maybe,Integer) + +sizeGList (_,i) = i +indxGList (f,_) = f + +emptyGList :: GList +emptyGList = (const failTP,0) + +addGList :: Term t => t -> GList -> GList +addGList t l = (modify f s e,s+1) + where s = sizeGList l + f = indxGList l + e = monoTP (const (return t)) + +putGList :: Term t => Integer -> t -> GList -> GList +putGList i t l = if i < s then (modify f i e,s) + else l + where s = sizeGList l + f = indxGList l + e = monoTP (const (return t)) + +getGList :: Term t => Integer -> GList -> Maybe t +getGList i l = if i < s then applyTP (f i) undefined + else Nothing + where f = indxGList l + s = sizeGList l + +mapGListTP :: TP Maybe -> GList -> GList +mapGListTP s l = (nth (map forElem [0..size-1]),size) + where forElem :: Integer -> TP Maybe + forElem i = (indxGList l i) `seqTP` s + size = sizeGList l + +mapGListTU :: Term t => (t -> ()) -> TU a Maybe -> GList -> [Maybe a] +mapGListTU g s l= map forElem [0..size-1] + where forElem i + = applyTU ((indxGList l i) `seqTU` s) t + size = sizeGList l + (t,()) = (undefined,g t) + +elemsGList :: Term t => (t -> ()) -> GList -> [t] +elemsGList g l = filterJust (map forElem [0..size-1]) + where forElem i + = applyTP (indxGList l i) t + size = sizeGList l + (t,()) = (error "NOTERM",g t) + filterJust as = map unJust (filter isJust as) + unJust (Just t) = t + isJust (Just _) = True + isJust Nothing = False + +-- Variation on !! but now for Integer iso Int +nth :: [a] -> Integer -> a +nth (x:_) 0 = x +nth (_:xs) n | n>0 = nth xs (n-1) +nth (_:_) _ = error "ContainterTheme.nth: negative index" +nth [] _ = error "ContainerTheme.nth: index too large" + +------------------------------------------------------------------------------ +--- Assign unique codes to terms of any type --------------------------------- + +type Coder = (Int,TU Int Maybe) + +noCode :: Coder +noCode = (0,failTU) + +getCode :: Term x => Coder -> x -> Maybe Int +getCode (_,s) = applyTU s + +setCode :: (Term x, Eq x) => Coder -> x -> Int -> Coder +setCode (i,s) x i' = (i,modifyTU s x (return i')) + +nextCode :: Coder -> (Int,Coder) +nextCode (i,s) = (i,(i+1,s)) + +enCode :: (Term x, Eq x) => Coder -> x -> Coder +enCode c x = maybe gen found (getCode c x) + where + gen = let (i,c') = nextCode c + in setCode c' x i + found = const c + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/EffectTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/EffectTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/EffectTheme.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- provides combinators to localize monadic effects. +-- +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.EffectTheme ( + -- * Replace one strategy monad by another + mrunTP, mrunTU, + -- * Add an effect to the strategy monad + liftTP, liftTU, + -- * Remove an effect from the strategy monad + unliftTP, unliftTU, + -- * Localize specific effects + -- ** Localize the partiality effect + guaranteeSuccessTP, guaranteeSuccessTU, + unsafeGuaranteeSuccessTP, + -- ** Localize the state effect + localStateTP, localStateTU, +) where + + +import Control.Monad +import Control.Monad.Run +import Control.Monad.Trans +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme +import Data.Generics.Strafunski.StrategyLib.StrategyPrimitives + + +------------------------------------------------------------------------------ + +-- * Replace one strategy monad by another + +-- The two monads are unrelated. +-- The first is run, and the resulting value is returned in the other. +-- We use the `run' function of one monad, and the `return' function +-- of the other. + +-- | Replace the monad in a type-preserving strategy, given a monad +-- algebra (see 'MonadRun') for the monad that is replaced. The two +-- monads are unrelated, so none of the effects in the monad that is +-- replaced carry over to the one that replaces it. +mrunTP :: (Monad m, Monad m', MonadRun s m) + => (forall a . s a a) -> TP m -> TP m' +mrunTP alg = msubstTP (mrun alg) + +-- | Replace the monad in a type-unifying strategy, given a monad +-- algebra (see 'MonadRun') for the monad that is replaced. The two +-- monads are unrelated, so none of the effects in the monad that is +-- replaced carry over to the one that replaces it. +mrunTU :: (Monad m, Monad m', MonadRun s m) + => s a a -> TU a m -> TU a m' +mrunTU alg = msubstTU (mrun alg) + + +------------------------------------------------------------------------------ +-- * Add an effect to the strategy monad + +-- | Add an effect to the monad in a type-preserving strategy. +-- The monads are related by a monad transformer, so the effects of the +-- incoming monad are preserved in the result monad. We use the `lift' +-- function of the monad transformer. +liftTP :: (Monad (t m), Monad m, MonadTrans t) => TP m -> TP (t m) +liftTP = msubstTP lift + +-- | Add an effect to the monad in a type-unifying strategy. +-- The monads are related by a monad transformer, so the effects of the +-- incoming monad are preserved in the result monad. We use the `lift' +-- function of the monad transformer. +liftTU :: (Monad (t m), Monad m, MonadTrans t) => TU a m -> TU a (t m) +liftTU = msubstTU lift + + +------------------------------------------------------------------------------ +-- * Remove an effect from the strategy monad + +-- | remove an effect from the monad of a type-preserving strategy. +-- The monads are related by a monad untransformer (see 'MonadUnTrans'), +-- so the effects of the incoming monad are preserved in the result +-- monad, except for the effect for which a monad algebra is supplied. +unliftTP :: (Monad (t m), Monad m, MonadUnTrans s t) + => (forall a . s a a) -> TP (t m) -> TP m +unliftTP alg = msubstTP (unlift alg) + +-- | remove an effect from the monad of a type-unifying strategy. +-- The monads are related by a monad untransformer (see 'MonadUnTrans'), +-- so the effects of the incoming monad are preserved in the result +-- monad, except for the effect for which a monad algebra is supplied. +unliftTU :: (Monad (t m), Monad m, MonadUnTrans s t) + => s a a -> TU a (t m) -> TU a m +unliftTU alg = msubstTU (unlift alg) + +-- Does not work: +-- unliftS alg = msubstS (unlift alg) + + +------------------------------------------------------------------------------ +-- * Localize specific effects + +-- ** Localize the partiality effect + +-- Safe versions provide default to cope with Nothing. +-- Note the explicit universal quantification of this value +-- in the TP case. + +-- | Localize the partiality effect in a type-preserving strategy. A +-- default value must be supplied to be used to recover from +-- failure. Since this default parameter is universally quantified, +-- only 'undefined' and 'error ...' can be used to instantiate it. +-- See also 'unsafeGuaranteeSuccessTP. +guaranteeSuccessTP :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) + => (forall a . a) -- ^ default value (Note: universally quantified!) + -> TP (t m) -- ^ type-preserving partial strategy + -> TP m -- ^ type-preserving strategy without partiality +guaranteeSuccessTP x s + = unliftTP (MaybeAlg x id) s + +-- | Localize the partiality effect in a type-unifying strategy. A +-- default value must be supplied to be used to recover from +-- failure. +guaranteeSuccessTU :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) + => a -- ^ default value + -> TU a (t m) -- ^ type-preserving partial strategy + -> TU a m -- ^ type-preserving strategy without partiality +guaranteeSuccessTU x s + = unliftTU (MaybeAlg x id) s + +-- Does not work: +-- guaranteeSuccessS :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) +-- => a -> TU a (t m) -> TU a m +-- guaranteeSuccessS x s +-- = msubstS (unlift (MaybeAlg x id)) s + +-- | Unsafe version of 'guaranteeSuccessTP'. This version uses uses `undefined' +-- to recover from failure. For the type-preserving case, this is the only +-- possible default value. +unsafeGuaranteeSuccessTP :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) + => TP (t m) -> TP m +unsafeGuaranteeSuccessTP s + = guaranteeSuccessTP undefined s + +-- | Unsafe version of 'guaranteeSuccessTU'. This version uses uses `undefined' +-- to recover from failure. Use 'guaranteeSuccessTU' instead. +unsafeGuaranteeSuccessTU :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) + => TU a (t m) -> TU a m +unsafeGuaranteeSuccessTU s + = guaranteeSuccessTU undefined s + +-- Does not work: +-- unsafeGuaranteeSuccessS s +-- = guaranteeSuccessS undefined s + +------------------------------------------------------------------------------ +-- ** Localize the state effect + +-- | Localize the state of a type-preserving strategy. The first argument +-- represents the initial state. +localStateTP :: (Monad (t m), Monad m, MonadUnTrans (StateAlg s) t) + => s -> TP (t m) -> TP m +localStateTP s + = unliftTP (StateAlg s fst) + +-- | Localize the state of a type-unifying strategy. The first argument +-- represents the initial state. +localStateTU :: (Monad (t m), Monad m, MonadUnTrans (StateAlg s) t) + => s -> TU a (t m) -> TU a m +localStateTU s + = unliftTU (StateAlg s fst) + + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/FixpointTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/FixpointTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/FixpointTheme.hs @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- defines combinators that iterate until some kind of fixpoint is reached. +-- +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.FixpointTheme where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.FlowTheme +import Data.Generics.Strafunski.StrategyLib.TraversalTheme +import Control.Monad + + +------------------------------------------------------------------------------ +-- * Fixpoint Iteration + + +-- | Exhaustive repeated application at the root of the input term +repeatTP :: MonadPlus m => TP m -> TP m +repeatTP s = tryTP (seqTP s (repeatTP s)) + + + +------------------------------------------------------------------------------ +-- * Fixpoint Traversal + + +-- | Exhaustive repeated application throughout the input term. +reduce :: MonadPlus m => TP m -> TP m +reduce s = repeatTP (someTP (reduce s) `choiceTP` s) + +-- | Exhaustive repeated application according to the left-most +-- outermost traversal strategy. +outermost :: MonadPlus m => TP m -> TP m +outermost s = repeatTP (once_tdTP s) + +-- | Exhaustive repeated application according to the left-most +-- innermost traversal strategy, implemented in a naive way. +-- Use 'innermost' instead. +innermost' :: MonadPlus m => TP m -> TP m +innermost' s = repeatTP (once_buTP s) + +-- | Exhaustive repeated application according to the left-most +-- innermost traversal strategy, implemented in a more +-- efficient way. +innermost :: MonadPlus m => TP m -> TP m +innermost s = allTP (innermost s) + `seqTP` + (tryTP (s `seqTP` (innermost s))) + +------------------------------------------------------------------------------ + diff --git a/library/Data/Generics/Strafunski/StrategyLib/FlowTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/FlowTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/FlowTheme.hs @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- defines combinators to wire up control and data flow. Whenever possible, +-- we define the combinators in an overloaded fashion but we provide +-- type-specialised variants for TP and TU for convenience. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.FlowTheme where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme +import Control.Monad +import Data.Monoid + + +------------------------------------------------------------------------------ +-- * Try: recover from failure + +-- | Attempt a strategy 's', but recover if it fails. +tryS :: (StrategyPlus s m, StrategyMonoid s m) => s m -> s m +tryS s = s `choiceS` skipS + +-- | Attempt a type-preserving strategy 's', but if it fails, return the +-- input term unchanged. +tryTP :: MonadPlus m => TP m -> TP m +tryTP = tryS + +-- | Attempt a type-unifying strategy 's', but if it fails, return the +-- 'mempty' element of a 'Monoid'. +tryTU :: (MonadPlus m, Monoid u) => TU u m -> TU u m +tryTU = tryS + + +------------------------------------------------------------------------------ +-- * Test: ignore result, but retain effects + +-- | Test for a strategy's success in a type-preserving context. +testS :: Strategy s m => s m -> TP m +testS s = voidS s `passS` const idTP + +-- | Test for a type-preserving strategy's success in a +-- type-preserving context. +testTP :: Monad m => TP m -> TP m +testTP = testS + +-- | Test for a type-unifying strategy's success in a +-- type-preserving context. +testTU :: Monad m => TU a m -> TP m +testTU = testS + + +------------------------------------------------------------------------------ +-- * If-then-else: pass value from condition to then-clause + +-- | If 'c' succeeds, pass its value to the then-clause 't', +-- otherwise revert to the else-clause 'e'. +ifS :: StrategyPlus s m => TU u m -> (u -> s m) -> s m -> s m +ifS c t e = ((c `passTU` (constTU . Just)) `choiceTU` constTU Nothing) + `passS` + maybe e t + +-- | If 'c' succeeds, pass its value to the then-clause 't', +-- otherwise revert to the else-clause 'e'. +ifTP :: MonadPlus m => TU u m -> (u -> TP m) -> TP m -> TP m +ifTP = ifS + +-- | If 'c' succeeds, pass its value to the then-clause 't', +-- otherwise revert to the else-clause 'e'. +ifTU :: MonadPlus m => TU u m -> (u -> TU u' m) -> TU u' m -> TU u' m +ifTU = ifS + + +------------------------------------------------------------------------------ +-- * If-then: disciplined form of a guarding + +-- | Guard then-clause 't' by the void-valued type-unifying +-- condition 'c'. +ifthenS :: Strategy s m => TU () m -> s m -> s m +ifthenS c t = c `passS` const t + +-- | Guard type-preserving then-clause 't' by the void-valued type-unifying +-- condition 'c'. +ifthenTP :: Monad m => TU () m -> TP m -> TP m +ifthenTP = ifthenS + +-- | Guard type-unifying then-clause 't' by the void-valued type-unifying +-- condition 'c'. +ifthenTU :: Monad m => TU () m -> TU u m -> TU u m +ifthenTU = ifthenS + + +------------------------------------------------------------------------------ +-- * Not: negation by failure + +-- | Invert the success-value of strategy 's'. +notS :: StrategyPlus s m => s m -> TP m +notS s = ifS (voidS s) (const failTP) idTP + +-- | Invert the success-value of type-preserving strategy 's'. Its output +-- term (in case of success) will be ignored. +notTP :: MonadPlus m => TP m -> TP m +notTP = notS + +-- | Invert the success-value of type-unifying strategy 's'. Its output +-- value (in case of success) will be ignored. +notTU :: MonadPlus m => TU u m -> TP m +notTU = notS + + +------------------------------------------------------------------------------ +-- * Exclusive choice + +-- | Succeed if exactly one argument strategy succeeds. +xchoiceS :: StrategyPlus s m => s m -> s m -> s m +s `xchoiceS` s' = (notS s' `seqS` s) `choiceS` (notS s `seqS` s') + +-- | Succeed if exactly one argument strategy succeeds. +xchoiceTP :: MonadPlus m => TP m -> TP m -> TP m +xchoiceTP = choiceS + +-- | Succeed if exactly one argument strategy succeeds. +xchoiceTU :: MonadPlus m => TU u m -> TU u m -> TU u m +xchoiceTU = choiceS + + +------------------------------------------------------------------------------ +-- * Generic filter, derived from monomorphic predicate + +-- | If predicate 'g' holds for the input term, return it as output term, +-- otherwise fail. +filterTP :: (Term t, MonadPlus m) => (t -> Bool) -> TP m +filterTP g = monoTP (\x -> if g x then return x else mzero) + +-- | If predicate 'g' holds for the input term, return it as output value, +-- otherwise fail. +filterTU :: (Term t, MonadPlus m) => (t -> Bool) -> TU t m +filterTU g = monoTU (\x -> if g x then return x else mzero) + + +------------------------------------------------------------------------------ +-- * Generic ticker, derived from monomorphic predicate + +-- | If predicate 'g' holds for the input term, +-- return 1 otherwise return 0. +tickTU :: (Monad m, Term t, Num n) => (t -> Bool) -> TU n m +tickTU g = adhocTU (constTU 0) (\t -> return (if g t then 1 else 0)) + + +------------------------------------------------------------------------------ +-- * Type guards + +-- | Type guard (function type), i.e., guard that does not observe values +type TypeGuard a = a -> () + +-- | Type guard (function). +-- Typical usage: +-- +-- @ +-- full_tdTU (typeTickTU (typeGuard::TypeGuard MyType)) +-- @ +typeGuard :: TypeGuard a +typeGuard = const () + +------------------------------------------------------------------------------ +-- * Generic ticker, derived from type guard + +-- | If type guard holds for the input term, +-- return 1 otherwise return 0. +typeTickTU :: (Term t, Monad m, Num n) => TypeGuard t -> TU n m +typeTickTU g = adhocTU (constTU 0) ((\() -> return 1) . g) + + +------------------------------------------------------------------------------ +-- * Generic filters, derived from type guard + +-- | If type guard holds for the input term, return it as output term, +-- otherwise fail. +typeFilterTP :: (Term t, MonadPlus m) => TypeGuard t -> TP m +typeFilterTP g = monoTP (\x -> ((\() -> return x) . g) x) + +-- | If type guard holds for the input term, return it as output value, +-- otherwise fail. +typeFilterTU :: (Term t, MonadPlus m) => TypeGuard t -> TU t m +typeFilterTU g = monoTU (\x -> ((\() -> return x) . g) x) + + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/KeyholeTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/KeyholeTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/KeyholeTheme.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleInstances #-} +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- defines a number combinators for keyhole operations, i.e. for operations +-- that have ordinary parametric or adhoc polymorhpic types, but employ +-- strategies inside. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.KeyholeTheme where + +import Control.Monad +import Control.Monad.Identity +import Data.Generics.Strafunski.StrategyLib.MonadicFunctions +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme +import Data.Generics.Strafunski.StrategyLib.PathTheme +import Data.Generics.Strafunski.StrategyLib.FlowTheme +import Data.Generics.Strafunski.StrategyLib.TraversalTheme + + +------------------------------------------------------------------------------ +-- * Focus + +-- | Select the identified focus. +-- Fails if no subterm can be selected. +selectFocus :: (Term f, Term t) + => (f -> Maybe f) -- ^ Identify focus + -> t -- ^ Input term + -> Maybe f -- ^ Focused term +selectFocus unwrap = applyTU (once_tdTU (adhocTU failTU unwrap)) + +-- | Replace the identified focus. +-- Fails if no subterm can be replaced. +replaceFocus :: (Term t, Term t') + => (t -> Maybe t) -- Transform focus + -> t' -- Input term + -> Maybe t' -- Output term +replaceFocus trafo = applyTP (once_tdTP (adhocTP failTP trafo)) + +-- | Delete the focus assuming it is an element in a list. +-- Fails if no deletion can be performed. +deleteFocus :: (Term f, Term [f], Term t) + => (f -> Maybe f) -- ^ Identify focus + -> t -- ^ Input term + -> Maybe t -- ^ Output term without focused entity +deleteFocus unwrap = applyTP (once_tdTP (adhocTP failTP filterF)) + where + filterF xs = do { xs' <- filterM pred xs; + guard (length xs - 1 == length xs'); + return xs' + } + pred x = (unwrap x >>= \_ -> return False) + `mplus` + return True + +-- | Find the host of the focused entity, i.e. a superterm of the +-- focussed subterm. +selectHost :: (Term f, Term h, Term t) + => (f -> Maybe f) -- ^ Get focus + -> (h -> Maybe h) -- ^ Get host + -> t -- ^ Input term + -> Maybe h -- ^ Located host +selectHost getFocus getHost + = applyTU ( adhocTU failTU getHost + `aboveS` + (adhocTU failTU (\f -> getFocus f >>= return . const ())) ) + +-- Mark a host of a focused entity. +markHost :: (Term f, Term h, Term t) + => (f -> Bool) -- ^ Test focus + -> (h -> h) -- ^ Wrap host + -> t -- ^ Input term + -> Maybe t -- ^ Output term +markHost testFocus wrapHost = + applyTP (host `aboveS` focus) + where + host = adhocTP failTP (Just . wrapHost) + focus = adhocTU failTU (guard . testFocus) + + + +------------------------------------------------------------------------------ +-- * Listification + +-- | Put all nodes of a certain type into a list. +listify :: (Term x, Term y) => x -> [y] +listify = runIdentity . applyTU worker + where + worker = op2TU (++) process recurse + process = adhocTU (constTU []) (\x -> return [x]) + recurse = allTU (++) [] worker + +-- | Put all nodes of type 'String' into a list. This is a type-specialization +-- of 'listify'. +strings :: Term x => x -> [String] +strings = listify + +------------------------------------------------------------------------------ +-- * Keyhole versions of basic strategy combinators. + +-- | Apply the argument function to the unique subterm of the input term. +-- Fail if the input term has more subterms or if the subterm is not of +-- the appropriate type. This is a keyhole version of the traversal +-- combinator 'injTP' +inj :: (MonadPlus m, Term x, Term c) => (c -> m c) -> (x -> m x) +inj f = applyTP (injTP (adhocTP failTP f)) + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/MetricsTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/MetricsTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/MetricsTheme.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances #-} +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- defines combinators to define metrics extractors. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.MetricsTheme where + +import Control.Monad +import Data.Monoid +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme +import Data.Generics.Strafunski.StrategyLib.FlowTheme + +------------------------------------------------------------------------------ +-- * An abstract datatype for metrics + +-- | The type of metrics +newtype Metrics = M (MetricName -> Integer) + +-- | The type of metric names +type MetricName = String + +-- | Create 'Metrics' with given initial value for all metrics. +initMetrics :: Integer -> Metrics +initMetrics n = M $ \key -> n + +-- | Create 'Metrics' with 0 as initial value for all metrics. +initMetrics0 :: Metrics +initMetrics0 = initMetrics 0 + +-- | Create 'Metrics' with +--initTypeMetrics :: MetricName -> a -> Metrics +--initTypeMetrics key _ = incMetrics1 key initMetrics0 + +-- | Increment metric with the given name with the given value. +incMetrics :: MetricName -> Integer -> Metrics -> Metrics +incMetrics key n (M m) = M $ \key' -> let val = m key' + in if key'==key then val+n else val + +-- | Increment metric with the given name by 1. +incMetrics1 :: MetricName -> Metrics -> Metrics +incMetrics1 key m = incMetrics key 1 m + +-- | Print value of metric with the given name. +putMetricLn :: MetricName -> Metrics -> IO () +putMetricLn key (M m) = putStrLn $ key++" = "++show (m key) + + + +-- * Metrics as monoids +instance Monoid Metrics where + mempty = initMetrics0 + mappend (M m1) (M m2) = M $ \s -> (m1 s) + (m2 s) + + +------------------------------------------------------------------------------ +-- * Strategy combinators for metrics + +-- | Additionally collect type-based metrics. +typeMetric + :: (MonadPlus m, Term a) + => TU Metrics m -- ^ Metric collecting strategy + -> (MetricName,a -> ()) -- ^ Name of the metric and type guard + -> TU Metrics m -- ^ Strategy that additionally collects type-based metrics +typeMetric s (key,g) + = op2TU mappend + (tryTU (ifthenTU (voidTU (typeFilterTU g)) + (constTU (incMetrics1 key initMetrics0)))) + (tryTU s) + + +-- | Additionally collect predicate-based metrics. +predMetric + :: (MonadPlus m, Term b) + => TU Metrics m -- ^ Strategy that collects metrics + -> (MetricName,b -> m ()) -- ^ Name of the metric, and predicate + -> TU Metrics m -- ^ Strategy that additionally collects predicate-based metric +predMetric s (key,g) + = op2TU mappend + (tryTU (ifthenTU (monoTU g) + (constTU (incMetrics1 key initMetrics0)))) + (tryTU s) + +------------------------------------------------------------------------------ +-- * Generic metric algorithms + +-- | Generic algorithm for computing nesting depth +depthWith :: MonadPlus m + => TU () m -- ^ Recognize relevant contructs + -> TU Int m -- ^ Count nesting depth of relevant constructs. +depthWith s + = allTU' ((:[]) `dotTU` depthWith s) `passTU` \ds -> + let max_d = maximum (0:ds) + in (s `passTU` \() -> constTU (max_d + 1)) + `choiceTU` + (constTU max_d) + +------------------------------------------------------------------------------- diff --git a/library/Data/Generics/Strafunski/StrategyLib/MonadicFunctions.hs b/library/Data/Generics/Strafunski/StrategyLib/MonadicFunctions.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/MonadicFunctions.hs @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- defines auxilliary monadic functions, some of which serve as parametric +-- polymorphic prototypes for actual strategy combinators. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.MonadicFunctions where + +import Control.Monad + + +{- See Control.Monad.Identity +------------------------------------------------------------------------------ +-- * The identity monad + +-- | Identity type constructor. +newtype Id a = Id a + +-- | Unwrap identity type constructor +unId :: Id a -> a +unId (Id x) = x + +instance Monad Id where + return = Id + (Id x) >>= f = f x + +-} + +{- See Data.Maybe.fromJust +------------------------------------------------------------------------------ +-- * Recover from partiality + +-- | Force success. If the argument value corresponds to failure, +-- a run-time error will occur. +succeed :: Maybe x -> x +succeed (Just x) = x +succeed Nothing = error "Didn't succeed!." +-} + +------------------------------------------------------------------------------ +-- * Prototypes for strategy combinators seq, let, choice + +-- | Sequential composition of monadic functions +mseq :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c +f `mseq` g = \x -> f x >>= g + +-- | Sequential composition with value passing; a kind of monadic let. +mlet :: Monad m => (a -> m b) -> (b -> a -> m c) -> a -> m c +f `mlet` g = \x -> f x >>= \y -> g y x + +-- | Choice combinator for monadic functions +mchoice :: MonadPlus m => (a -> m b) -> (a -> m b) -> a -> m b +f `mchoice` g = \x -> (f x) `mplus` (g x) + +------------------------------------------------------------------------------ +-- * Guards and conditionals + +-- | Type guard described by the argument type of a function. +argtype :: MonadPlus m => (x -> y) -> x -> m () +argtype _ _ = return () + + +-- | Type guard described by a type of a value. +valtype :: MonadPlus m => x -> x -> m () +valtype _ _ = return () + +-- | A kind of monadic conditional. +ifM :: MonadPlus m => m a -> (a -> m c) -> (m c) -> (m c) +ifM ma f mc = ((ma >>= \a -> return (Just a)) + `mplus` (return Nothing) + ) >>= maybe mc f + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/NameTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/NameTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/NameTheme.hs @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- provides algorithms to collect names and their types. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.NameTheme where + +import Control.Monad +import Data.List +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme +import Data.Generics.Strafunski.StrategyLib.FlowTheme +import Data.Generics.Strafunski.StrategyLib.TraversalTheme +import Control.Monad.Identity hiding (fail) + + +------------------------------------------------------------------------------ +-- * Free name analysis + +-- | Generic free name analysis algorithm (without types) +freeNames :: (Eq name, Term t) + => TU [(name,tpe)] Identity -- ^ Identify declarations + -> TU [name] Identity -- ^ Identify references + -> t -- ^ Input term + -> [name] -- ^ Free names +freeNames declared referenced = + runIdentity . + applyTU (all_recTU (op2TU combine) + (op2TU (,) declared referenced)) + where + combine (decs,refs) recs = + (refs `union` recs) \\ (map fst decs) + +-- | Generic free name analysis algorithm with types +freeTypedNames :: (Eq name, Term t) + => TU [(name,tpe)] Identity -- ^ Identify declarations + -> TU [name] Identity -- ^ Identify references + -> [(name,tpe)] -- ^ Derived declarations + -> t -- ^ Input term + -> [(name,tpe)] -- ^ Free names with types +freeTypedNames declared referenced types t = + filter (\e -> elem (fst e) names) types + where + names = freeNames declared referenced t + + +------------------------------------------------------------------------------ +-- * Bound name analysis + +-- | Accumulate declarations for focus +boundTypedNames :: (Term f, Term t, Eq name) + => TU [(name,tpe)] Identity -- Identify declarations + -> (f -> Maybe f) -- Get focus + -> t -- Input term + -> Maybe ([(name,tpe)],f) -- Derived declarations +boundTypedNames declared unwrap = + applyTU (once_pe (adhocTU failTU . stop) bind []) + where + stop inh = + (maybe Nothing (Just . (,) inh)) . + unwrap + bind inh = + msubstTU (Just . runIdentity) declared `passTU` \decs -> + constTU (unionBy byName decs inh) + byName = \a -> \a' -> fst a == fst a' + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/OverloadingTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/OverloadingTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/OverloadingTheme.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- overloads basic combinators to enable uniform treatment of TU and TP +-- strategies. The overloading scheme is motivated in the +-- "... Polymorphic Symphony" paper. The names in the present module +-- deviate from the paper in that they are postfixed by an "...S" +-- in order to rule out name clashes and to avoid labour-intensive +-- resolution. The class constraints in this module seem to be outrageous +-- but this has to do with a type inferencing bug for class hierarchies +-- in hugs. This bug is removed in the October 2002 release. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.OverloadingTheme where + +import Control.Monad +import Data.Monoid +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude + + +------------------------------------------------------------------------------ +-- * Unconstrained + +-- | Overload completely unconstrained strategy combinators +class Monad m => Strategy s m + where + voidS :: s m -> TU () m + -- | Sequential composition + seqS :: TP m -> s m -> s m + -- | Sequential composition with value passing + passS :: TU a m -> (a -> s m) -> s m + +instance Monad m => Strategy TP m + where + voidS = voidTP + seqS = seqTP + passS = passTP + +instance Monad m => Strategy (TU a) m + where + voidS = voidTU + seqS = seqTU + passS = passTU + +-- | Overload apply and adhoc combinators +class (Strategy s m, Monad m, Term t) => StrategyApply s m t x | s t -> x + where + -- | Strategy application + applyS :: s m -> t -> m x + -- | Dynamic type case + adhocS :: s m -> (t -> m x) -> s m + +instance (Monad m, Term t) => StrategyApply TP m t t + where + applyS = applyTP + adhocS = adhocTP + +instance (Monad m, Term t) => StrategyApply (TU a) m t a + where + applyS = applyTU + adhocS = adhocTU + +------------------------------------------------------------------------------ +-- * Involving Monoid, MonadPlus, + +-- | Overload basic combinators which might involve a monoid +class (Monad m, Strategy s m) => StrategyMonoid s m + where + -- | Identity (success) + skipS :: s m + -- | Push down to all children + allS :: s m -> s m + -- | Combine sequentially + combS :: s m -> s m -> s m + +instance (Monad m, Strategy TP m) => StrategyMonoid TP m + where + skipS = idTP + allS = allTP + combS = seqTP + +instance (Monad m, Monoid u, Strategy (TU u) m) => StrategyMonoid (TU u) m + where + skipS = constTU mempty + allS = allTU' + combS = op2TU mappend + + + +-- | Overload basic combinators which involve MonadPlus +class (Strategy s m, Monad m, MonadPlus m) => StrategyPlus s m + where + -- | Failure + failS :: s m + -- | Choice + choiceS :: s m -> s m -> s m + -- | Push down to a single child + oneS :: s m -> s m + +instance (Monad m, MonadPlus m, Strategy TP m) => StrategyPlus TP m + where + failS = failTP + choiceS = choiceTP + oneS = oneTP + +instance (Monad m, MonadPlus m, Strategy (TU u) m) => StrategyPlus (TU u) m + where + failS = failTU + choiceS = choiceTU + oneS = oneTU + + +-- | Overloaded lifting with failure +monoS :: (StrategyApply s m t x, StrategyPlus s m) + => (t -> m x) + -> s m +monoS f = adhocS failS f + + +------------------------------------------------------------------------------ +-- * Effect substitution (see "EffectTheme"). + +-- | Overload msubst combinator (Experimental) +class StrategyMSubst s + where + -- | Substitute one monad for another + msubstS :: (Monad m, Monad m') => (forall t . m t -> m' t) -> s m -> s m' + +instance StrategyMSubst TP + where + msubstS f = msubstTP f + +instance StrategyMSubst (TU a) + where + msubstS f = msubstTU f + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/PathTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/PathTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/PathTheme.hs @@ -0,0 +1,83 @@ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. In this module, we +-- define path combinator to constrain selection and transformation of nodes or +-- subtrees by path conditions. + +-----------------------------------------------------------------------------} + +module Data.Generics.Strafunski.StrategyLib.PathTheme where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme +import Data.Generics.Strafunski.StrategyLib.FlowTheme +import Data.Generics.Strafunski.StrategyLib.TraversalTheme +import Control.Monad + + +------------------------------------------------------------------------------ +-- * Below + +-- ** Strictly below + +-- | Select or transform a node below a node where a condition holds. +-- We find the top-most node which admits selection or transformation +-- below the top-most node which meets the condition. Thus, the +-- distance between guard and application node is minimized. +belowS :: (MonadPlus m, Strategy s m, StrategyPlus s m) + => s m -> TU () m -> s m +s `belowS` s' = (oneS s) `beloweqS` s' + +-- ** Below or at the same height + +-- | Select or transform a node below or at a node where a condition holds. +beloweqS :: (MonadPlus m, Strategy s m, StrategyPlus s m) + => s m -> TU () m -> s m +s `beloweqS` s' = once_td (ifthenS s' (once_td s)) + +-- ** Type-specialised versions + +-- | Apply a transformation strictly below a node where a condition holds. +belowTP :: MonadPlus m => TP m -> TU () m -> TP m +belowTP = belowS + +-- | Apply a transformation below or at a node where a condition holds. +beloweqTP :: MonadPlus m => TP m -> TU () m -> TP m +beloweqTP = beloweqS + + + +------------------------------------------------------------------------------ +-- * Above + +-- ** Strictly above + +-- | Select or transform a node above a node where a condition holds. The +-- distance between guard and application node is minimized. +aboveS :: (MonadPlus m, Strategy s m, StrategyPlus s m) + => s m -> TU () m -> s m +s `aboveS` s' = s `aboveeqS` (oneTU s') + +-- ** Above or at the same height + +-- | Select or transform a node above or at a node where a condition holds. +aboveeqS :: (MonadPlus m, Strategy s m, StrategyPlus s m) + => s m -> TU () m -> s m +s `aboveeqS` s' = once_bu (ifthenS (once_tdTU s') s) + +-- ** Type-specialised versions + +-- | Apply a transformation strictly above a node where a condition holds. +aboveTP :: MonadPlus m => TP m -> TU () m -> TP m +aboveTP = aboveS + +-- | Apply a transformation above or at a node where a condition holds. +aboveeqTP :: MonadPlus m => TP m -> TU () m -> TP m +aboveeqTP = aboveeqS + +------------------------------------------------------------------------------ + diff --git a/library/Data/Generics/Strafunski/StrategyLib/RefactoringTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/RefactoringTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/RefactoringTheme.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- defines generic refactoring functionality. See the paper "Towards +-- Generic Refactoring" by Ralf Laemmel. See also +-- generic-refactoring in the examples directory. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.RefactoringTheme where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Control.Monad.Identity hiding (fail) +import Data.Generics.Strafunski.StrategyLib.KeyholeTheme +import Data.Generics.Strafunski.StrategyLib.NameTheme + + +------------------------------------------------------------------------------ +-- * The abstraction interface + +-- | Class of abstractions +class ( + -- Syntactical domains + Term abstr, -- Term type for abstraction + Eq name, -- Names of abstraction + Term [abstr], -- Lists of abstractions + Term apply -- Applications + ) + => Abstraction abstr name tpe apply + + -- Dependencies between syntactical domains + | abstr -> name, + abstr -> tpe, + abstr -> apply, + apply -> name, + apply -> abstr + + where + + -- Observers + getAbstrName :: abstr -> Maybe name + getAbstrParas :: abstr -> Maybe [(name,tpe)] + getAbstrBody :: abstr -> Maybe apply + getApplyName :: apply -> Maybe name + getApplyParas :: apply -> Maybe [(name,tpe)] + + -- Constructors + constrAbstr :: name -> [(name,tpe)] -> apply -> Maybe abstr + constrApply :: name -> [(name,tpe)] -> Maybe apply + + + +------------------------------------------------------------------------------ +-- * Removal + +-- | Remove an unused abstraction +eliminate :: (Term prog, Abstraction abstr name tpe apply) + => TU [(name,tpe)] Identity -- ^ Identify declarations + -> TU [name] Identity -- ^ Identify references + -> (abstr -> Maybe abstr) -- ^ Unwrap abstraction + -> prog -- ^ Input program + -> Maybe prog -- ^ Output program + +eliminate declared referenced unwrap prog + = do { abstr <- selectFocus unwrap prog; + name <- getAbstrName abstr; + () <- unusedAbstr name; + deleteFocus unwrap prog + } + + where + + -- Check if name is unused by optionally navigating to the relevant scope + unusedAbstr name = maybe (notIsFree prog) notIsFree selectScope + where + argtype :: Monad m => (x -> y) -> x -> m x + argtype _ = return + selectScope = selectHost unwrap (argtype unwrap) prog + notIsFree scope + = do + scope' <- deleteFocus unwrap scope + names <- return (freeNames declared referenced scope') + guard (not (elem name names)) + + +------------------------------------------------------------------------------ +-- * Insertion + +-- | Insert a new abstraction +introduce :: (Term prog, Abstraction abstr name tpe apply) + => TU [(name,tpe)] Identity -- ^ Identify declarations + -> TU [name] Identity -- ^ Identify references + -> ([abstr] -> Maybe [abstr]) -- ^ Unwrap scope with abstractions + -> abstr -- ^ Abstraction to be inserted + -> prog -- ^ Input program + -> Maybe prog -- ^ Output program + +introduce declared referenced unwrap abstr = + replaceFocus (\abstrlist -> + do + abstrlist' <- unwrap abstrlist + name <- getAbstrName abstr + free <- return $ freeNames declared referenced abstrlist' + def <- mapM getAbstrName abstrlist' + guard (and [not (elem name free), not (elem name def)]) + return (abstr:abstrlist') ) + + +------------------------------------------------------------------------------ +-- * Generic extraction (say fold) + +-- | Extract an abstraction +extract :: (Term prog, Abstraction abstr name tpe apply) + => TU [(name,tpe)] Identity -- ^ Identify declarations + -> TU [name] Identity -- ^ Identify references + -> (apply -> Maybe apply) -- ^ Unwrap focus + -> ([abstr] -> [abstr]) -- ^ Wrap host + -> ([abstr] -> Maybe [abstr]) -- ^ Unwrap host + -> ([(name,tpe)] -> apply -> Bool) -- ^ Check focus + -> name -- ^ Name for abstraction + -> prog -- ^ Input program + -> Maybe prog -- ^ Output program + +extract declared referenced unwrap wrap unwrap' check name prog + = do + -- Operate on focus + (bound,focus) <- boundTypedNames declared unwrap prog + free <- return $ freeTypedNames declared referenced bound focus + guard (check bound focus) + + -- Construct abstraction + abstr <- constrAbstr name free focus + + -- Insert abstraction + prog' <- markHost (maybe False (const True) . unwrap) wrap prog + prog'' <- introduce declared referenced unwrap' abstr prog' + + -- Construct application + apply <- constrApply name free + + -- Replace focus by application + replaceFocus (maybe Nothing (const (Just apply)) . unwrap) prog'' + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/StrategyInfix.hs b/library/Data/Generics/Strafunski/StrategyLib/StrategyInfix.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/StrategyInfix.hs @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- indicates how some strategy combinators could be denoted via infix +-- combinators. + +-----------------------------------------------------------------------------} + +module Data.Generics.Strafunski.StrategyLib.StrategyInfix where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme + +infixl 1 >>>, >>>=, >>>- +infixl 2 -+ + +-- | Sequential composition +(>>>) :: Strategy s m => TP m -> s m -> s m +s >>> s' = s `seqS` s' + +-- | Sequential composition with value passing +(>>>=) :: Strategy s m => TU a m -> (a -> s m) -> s m +s >>>= s' = s `passS` s' + +-- | Sequential composition, ignoring value from first strategy +(>>>-) :: Strategy s m => TU a m -> s m -> s m +s >>>- s' = s `passS` \_ -> s' + +-- | Dynamic type-case +(-+) :: StrategyApply s m t x => s m -> (t -> m x) -> s m +s -+ f = s `adhocS` f + +{- +tst :: TP Maybe +tst = idTP >>> failS -+ f -+ f + +f (x::Char) = return x + +mytest :: Maybe Char +mytest = applyTP tst 'a' + +mytest2 :: Maybe Bool +mytest2 = applyTP tst True +-} diff --git a/library/Data/Generics/Strafunski/StrategyLib/StrategyPrelude.hs b/library/Data/Generics/Strafunski/StrategyLib/StrategyPrelude.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/StrategyPrelude.hs @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module +-- is basically a wrapper for the strategy primitives plus some extra +-- basic strategy combinators that can be defined immediately in terms +-- of the primitive ones. + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.StrategyPrelude ( + module Data.Generics.Strafunski.StrategyLib.StrategyPrimitives, + module Data.Generics.Strafunski.StrategyLib.StrategyPrelude +) where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrimitives +import Control.Monad +import Data.Monoid + + +------------------------------------------------------------------------------ +-- * Useful defaults for strategy update (see 'adhocTU' and 'adhocTP'). + +-- | Type-preserving identity. Returns the incoming term without change. +idTP :: Monad m => TP m +idTP = paraTP return + +-- | Type-preserving failure. Always fails, independent of the incoming +-- term. Uses 'MonadPlus' to model partiality. +failTP :: MonadPlus m => TP m +failTP = paraTP (const mzero) + +-- | Type-unifying failure. Always fails, independent of the incoming +-- term. Uses 'MonadPlus' to model partiality. +failTU :: MonadPlus m => TU a m +failTU = paraTU (const mzero) + +-- | Type-unifying constant strategy. Always returns the argument value 'a', +-- independent of the incoming term. +constTU :: Monad m => a -> TU a m +constTU a = paraTU (const (return a)) + +-- | Type-unifying monadic constant strategy. Always performs the argument +-- computation 'a', independent of the incoming term. This is a monadic +-- variation of 'constTU'. +compTU :: Monad m => m a -> TU a m +compTU a = paraTU (const a) + + +------------------------------------------------------------------------------ +-- * Lift a function to a strategy type with failure as default + +-- | Apply the monomorphic, type-preserving argument function, if its +-- input type matches the input term's type. Otherwise, fail. +monoTP :: (Term a, MonadPlus m) => (a -> m a) -> TP m +monoTP = adhocTP failTP + +-- | Apply the monomorphic, type-unifying argument function, if its +-- input type matches the input term's type. Otherwise, fail. +monoTU :: (Term a, MonadPlus m) => (a -> m b) -> TU b m +monoTU = adhocTU failTU + + +------------------------------------------------------------------------------ +-- * Function composition + +-- | Sequential ccomposition of monomorphic function and type-unifying strategy. +-- In other words, after the type-unifying strategy 's' has been applied, +-- the monomorphic function 'f' is applied to the resulting value. +dotTU :: Monad m => (a -> b) -> TU a m -> TU b m +dotTU f s = s `passTU` (constTU . f) + + +-- | Parallel combination of two type-unifying strategies with a binary +-- combinator. In other words, the values resulting from applying the +-- type-unifying strategies are combined to a final value by applying +-- the combinator 'o'. + +op2TU :: Monad m => (a -> b -> c) -> TU a m -> TU b m -> TU c m +op2TU o s s' = s `passTU` \a -> + s' `passTU` \b -> + constTU (o a b) + + +------------------------------------------------------------------------------ +-- * Reduce a strategy's performance to its effects + +-- | Reduce a type-preserving strategy to a type-unifying one that +-- ignores its result term and returns void, but retains its +-- monadic effects. +voidTP :: Monad m => TP m -> TU () m +voidTP s = s `seqTU` constTU () + +-- | Reduce a type-unifying strategy to a type-unifying one that +-- ignores its result value and returns void, but retains its +-- monadic effects. +voidTU :: Monad m => TU u m -> TU () m +voidTU s = s `passTU` \_ -> constTU () + + +------------------------------------------------------------------------------ +-- * Shape test combinators + +-- | Test for constant term, i.e.\ having no subterms. +con :: MonadPlus m => TP m +con = allTP failTP + +-- | Test for compound term, i.e.\ having at least one subterm. +com :: MonadPlus m => TP m +com = oneTP idTP + + +------------------------------------------------------------------------------ diff --git a/library/Data/Generics/Strafunski/StrategyLib/TraversalTheme.hs b/library/Data/Generics/Strafunski/StrategyLib/TraversalTheme.hs new file mode 100644 --- /dev/null +++ b/library/Data/Generics/Strafunski/StrategyLib/TraversalTheme.hs @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- | +-- Maintainer : Ralf Laemmel, Joost Visser +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of 'StrategyLib', a library of functional strategy +-- combinators, including combinators for generic traversal. This module defines +-- traversal schemes. Such schemes have formed the core of StrategyLib +-- since its first release. The portfolio as it stands now captures part +-- of the design in the paper "... Polymorphic Symphony". + +------------------------------------------------------------------------------ + +module Data.Generics.Strafunski.StrategyLib.TraversalTheme where + +import Data.Generics.Strafunski.StrategyLib.StrategyPrelude +import Data.Generics.Strafunski.StrategyLib.OverloadingTheme +import Data.Generics.Strafunski.StrategyLib.FlowTheme +import Control.Monad +import Data.Monoid + + +------------------------------------------------------------------------------ +-- * Recursive traversal + +------------------------------------------------------------------------------ +-- ** Full traversals +-- +-- * td -- top-down +-- * bu -- bottom-up + +-- | Full type-preserving traversal in top-down order. +full_tdTP :: Monad m => TP m -> TP m +full_tdTP s = s `seqTP` (allTP (full_tdTP s)) + +-- | Full type-preserving traversal in bottom-up order. +full_buTP :: Monad m => TP m -> TP m +full_buTP s = (allTP (full_buTP s)) `seqTP` s + +-- | Full type-unifying traversal in top-down order. +full_tdTU :: (Monad m, Monoid a) => TU a m -> TU a m +full_tdTU s = op2TU mappend s (allTU' (full_tdTU s)) + + + +------------------------------------------------------------------------------ +-- ** Traversals with stop conditions + +-- | Top-down type-preserving traversal that is cut of below nodes +-- where the argument strategy succeeds. +stop_tdTP :: MonadPlus m => TP m -> TP m +stop_tdTP s = s `choiceTP` (allTP (stop_tdTP s)) + +-- | Top-down type-unifying traversal that is cut of below nodes +-- where the argument strategy succeeds. +stop_tdTU :: (MonadPlus m, Monoid a) => TU a m -> TU a m +stop_tdTU s = s `choiceTU` (allTU' (stop_tdTU s)) + + + +------------------------------------------------------------------------------ +-- ** Single hit traversal + +-- | Top-down type-preserving traversal that performs its argument +-- strategy at most once. +once_tdTP :: MonadPlus m => TP m -> TP m +once_tdTP s = s `choiceTP` (oneTP (once_tdTP s)) + +-- | Top-down type-unifying traversal that performs its argument +-- strategy at most once. +once_tdTU :: MonadPlus m => TU a m -> TU a m +once_tdTU s = s `choiceTU` (oneTU (once_tdTU s)) + +-- | Bottom-up type-preserving traversal that performs its argument +-- strategy at most once. +once_buTP :: MonadPlus m => TP m -> TP m +once_buTP s = (oneTP (once_buTP s)) `choiceTP` s + +-- | Bottom-up type-unifying traversal that performs its argument +-- strategy at most once. +once_buTU :: MonadPlus m => TU a m -> TU a m +once_buTU s = (oneTU (once_buTU s)) `choiceTU` s + + + +------------------------------------------------------------------------------ +-- ** Traversal with environment propagation + +-- | Top-down type-unifying traversal with propagation of an environment. +once_peTU :: MonadPlus m + => e -- ^ initial environment + -> (e -> TU e m) -- ^ environment modification at downward step + -> (e -> TU a m) -- ^ extraction of value, dependent on environment + -> TU a m +once_peTU e s' s = s e + `choiceTU` + (s' e `passTU` \e' -> oneTU (once_peTU e' s' s)) + + +------------------------------------------------------------------------------ +-- * One-layer traversal + +------------------------------------------------------------------------------ +-- ** Defined versions of some primitive one-layer traversal combinators + +-- For performance and uniformity reasons, anyTP and someTP are +-- primitives, but they could have been defined as follows: + +-- | Use 'anyTP' instead. +anyTP' :: MonadPlus m => TP m -> TP m +anyTP' s = allTP (tryTP s) + +-- | Use 'someTP' instead. +someTP' :: MonadPlus m => TP m -> TP m +someTP' s = (testTP (notTP (allTP (notTP s)))) `seqTP` (anyTP s) + + + +------------------------------------------------------------------------------ +-- ** Recursive completion of one-layer traversal + +-- | Recursive completion of full type-preserving one-layer traverasal +all_recTU :: (Monoid a, Monad m) + => (t -> TU a m -> TU a m) -- ^ binary strategy combinator + -> t -- ^ argument strategy + -> TU a m -- ^ result strategy +all_recTU o s = s `o` allTU' (all_recTU o s) + +-- | Recursive completion of type-preserving one-layer traversal that +-- succeeds exactly once. +one_recTU :: MonadPlus m + => (t -> TU a m -> TU a m) -- ^ binary strategy combinator + -> t -- ^ argument strategy + -> TU a m -- ^ result strategy +one_recTU o s = s `o` oneTU (one_recTU o s) + + +------------------------------------------------------------------------------ +-- * Overloading and synonyms + +------------------------------------------------------------------------------ +-- ** Overloaded schemes for traversal +-- See the paper "... Polymorphic symphony" for a discussion + +-- | Full top-down traversal (overloaded between 'TU' and 'TP'). +full_td :: StrategyMonoid s m => s m -> s m +full_td s = s `combS` (allS (full_td s)) + +-- | One-hit top-down traversal (overloaded between 'TU' and 'TP'). +once_td :: StrategyPlus s m => s m -> s m +once_td s = s `choiceS` (oneS (once_td s)) + +-- | One-hit bottom-up traversal (overloaded between 'TU' and 'TP'). +once_bu :: StrategyPlus s m => s m -> s m +once_bu s = (oneS (once_bu s)) `choiceS` s + +-- | One-hit top-down traversal with environment propagation +-- (overloaded between 'TU' and 'TP'). +once_pe :: StrategyPlus s m => (e -> s m) -> (e -> TU e m) -> e -> s m +once_pe s s' e = s e `choiceS` (s' e `passS` (\e' -> oneS (once_pe s s' e))) + + + +------------------------------------------------------------------------------ +-- ** Some synonyms for convenience + +-- | See 'full_tdTP'. +topdown :: Monad m => TP m -> TP m +topdown = full_tdTP + +-- | See 'full_tdTU'. +crush :: (Monad m, Monoid u) => TU u m -> TU u m +crush = full_tdTU + +-- | Type-specialised version of 'crush', which works with lists instead of +-- any arbitrary monoid. +collect :: Monad m => TU [a] m -> TU [a] m +collect = crush + +-- | See 'once_tdTU'. +select :: MonadPlus m => TU u m -> TU u m +select = once_tdTU + +-- | See 'once_peTU'. +selectenv :: MonadPlus m => e -> (e -> TU e m) -> (e -> TU a m) -> TU a m +selectenv = once_peTU + + +------------------------------------------------------------------------------ diff --git a/models/deriving/Data/Generics/Strafunski/StrategyLib/StrategyPrimitives.hs b/models/deriving/Data/Generics/Strafunski/StrategyLib/StrategyPrimitives.hs new file mode 100644 --- /dev/null +++ b/models/deriving/Data/Generics/Strafunski/StrategyLib/StrategyPrimitives.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE ExistentialQuantification #-} +{----------------------------------------------------------------------------- + +A model of functional strategies using Data.Generics as of >= GHC 6.2. +(The version of Data.Generics as of GHC 6.0 is not applicable here.) +Strategy application, strategy update, and traversal are different from +the original Strafunski model. Most other combinators (seqT?, ...) are +retained as is. + +-----------------------------------------------------------------------------} + +module Data.Generics.Strafunski.StrategyLib.StrategyPrimitives ( + + Term, + TP, TU, + paraTP, paraTU, + applyTP, applyTU, + adhocTP, adhocTU, + msubstTP, msubstTU, + seqTP, seqTU, + passTP, passTU, + choiceTP, choiceTU, + mchoicesTP, mchoicesTU, + allTP, allTU, allTU', + oneTP, oneTU, + anyTP, anyTU, anyTU', + someTP, someTU, someTU', + injTP + +) where + +import Data.Generics.Strafunski.StrategyLib.TermRep +import Data.Generics +import Control.Monad +import Data.Monoid +import Data.Generics.Strafunski.StrategyLib.MonadicFunctions +import Control.Monad.Run + + +--- Strategy representation -------------------------------------------------- + +newtype Monad m => + TP m = + MkTP (forall x. Data x => x -> m x) + +newtype Monad m => + TU a m = + MkTU (forall x. Data x => x -> m a) + +unTP (MkTP f) = f +unTU (MkTU f) = f + + + +--- Parametricially polymorphic strategies ----------------------------------- + +paraTP :: Monad m => (forall t. t -> m t) -> TP m +paraTP f = MkTP f + +paraTU :: Monad m => (forall t. t -> m a) -> TU a m +paraTU f = MkTU f + + +--- Strategy application ----------------------------------------------------- + +applyTP :: (Monad m, Data x) => TP m -> x -> m x +applyTP = unTP + +applyTU :: (Monad m, Data x) => TU a m -> x -> m a +applyTU = unTU + + + +--- Strategy update ---------------------------------------------------------- + +adhocTP :: (Monad m, Data t) => TP m -> (t -> m t) -> TP m +adhocTP s f = MkTP (unTP s `extM` f) + +adhocTU :: (Monad m, Data t) => TU a m -> (t -> m a) -> TU a m +adhocTU s f = MkTU (unTU s `extQ` f) + + + +--- Effect manipulation ------------------------------------------------------ + + -- Replace one monad by another + +msubstTP :: (Monad m, Monad m') + => (forall t . m t -> m' t) -> TP m -> TP m' +msubstTP e f = MkTP (\x -> e ((unTP f) x)) + +msubstTU :: (Monad m, Monad m') + => (m a -> m' a) -> TU a m -> TU a m' +msubstTU e f = MkTU (\x -> e ((unTU f) x)) + + + +--- Deterministic combinators ------------------------------------------------ + + -- Type-preserving + +seqTP :: Monad m => TP m -> TP m -> TP m +seqTP f g = MkTP ((unTP f) `mseq` (unTP g)) + +passTP :: Monad m => TU a m -> (a -> TP m) -> TP m +passTP f g = MkTP ((unTU f) `mlet` (\y -> unTP (g y))) + + -- Type-unifying + +seqTU :: Monad m => TP m -> TU a m -> TU a m +seqTU f g = MkTU ((unTP f) `mseq` (unTU g)) + +passTU :: Monad m => TU a m -> (a -> TU b m) -> TU b m +passTU f g = MkTU ((unTU f) `mlet` (\y -> unTU (g y))) + + + +--- Combinators for partiality and non-determinism --------------------------- + + -- Type-preserving + +choiceTP :: MonadPlus m => TP m -> TP m -> TP m +choiceTP f g = MkTP ((unTP f) `mchoice` (unTP g)) + + -- Type-unifying + +choiceTU :: MonadPlus m => TU a m -> TU a m -> TU a m +choiceTU f g = MkTU ((unTU f) `mchoice` (unTU g)) + +-- With localization of partiality: + +mchoicesTP fs f = MkTP (\a -> mchoices (map unTP fs) (unTP f) a) + +mchoicesTU fs f = MkTU (\a -> mchoices (map unTU fs) (unTU f) a) + + + +--- Traversal combinators ---------------------------------------------------- + + -- Type-preserving + +-- Succeed for all children +allTP :: Monad m => TP m -> TP m +allTP s = MkTP (gmapM (applyTP s)) + + +-- Succeed for one child; don't care about the other children +oneTP :: MonadPlus m => TP m -> TP m +oneTP s = MkTP (gmapMo (applyTP s)) + + +-- Succeed for as many children as possible +anyTP :: MonadPlus m => TP m -> TP m +anyTP s = allTP (s `choiceTP` paraTP return) + + +-- Succeed for as many children as possible but at least for one +someTP :: MonadPlus m => TP m -> TP m +someTP s = MkTP (gmapMp (applyTP s)) + + +-- Simulate injection +injTP :: MonadPlus m => TP m -> TP m +injTP s = (MkTU (return . glength)) + `passTP` + (\x -> if x == 1 then allTP s else paraTP (const mzero)) + + + -- Type-unifying + +allTU :: Monad m => (a -> a -> a) -> a -> TU a m -> TU a m +allTU op2 u s = MkTU (\x -> fold (gmapQ (applyTU s) x)) + where + fold l = foldM op2' u l + op2' x c = c >>= \y -> return (x `op2` y) + + +allTU' :: (Monad m, Monoid a) => TU a m -> TU a m +allTU' = allTU mappend mempty + + +oneTU :: MonadPlus m => TU a m -> TU a m +oneTU s = MkTU (\x -> fold (gmapQ (applyTU s) x)) + where + fold [] = mzero + fold (h:t) = (h >>= \x -> return x) + `mplus` + fold t + + +anyTU :: MonadPlus m => (a -> a -> a) -> a -> TU a m -> TU a m +anyTU op2 u s = allTU op2 u (s `choiceTU` paraTU (const (return u))) + + +anyTU' :: (MonadPlus m, Monoid a) => TU a m -> TU a m +anyTU' = anyTU mappend mempty + + +someTU :: MonadPlus m => (a -> a -> a) -> a -> TU a m -> TU a m +someTU op2 u s = MkTU (\x -> fold False (gmapQ (applyTU s) x)) + where + fold False [] = mzero + fold True [] = return u + fold b (h:t) = (h >>= \x -> fold True t >>= \y -> return (x `op2` y)) + `mplus` + fold b t + +someTU' :: (Monoid a, MonadPlus m) => TU a m -> TU a m +someTU' = someTU mappend mempty diff --git a/models/deriving/Data/Generics/Strafunski/StrategyLib/TermRep.hs b/models/deriving/Data/Generics/Strafunski/StrategyLib/TermRep.hs new file mode 100644 --- /dev/null +++ b/models/deriving/Data/Generics/Strafunski/StrategyLib/TermRep.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +-- +-- We use a little trick to turn the Data class into Strafunski's Term class. +-- No idea if this is going to work. +-- Cannot be tested right now because of GHC bugs. +-- + +module Data.Generics.Strafunski.StrategyLib.TermRep ( + Term +) where + +import Data.Generics + +class Data x => Term x + +instance (Typeable x, Data x) => Term x +