StrategyLib (empty) → 4.0.0.0

raw patch · 25 files changed

+2580/−0 lines, 25 filesdep +basedep +mtlbuild-type:Customsetup-changed

Dependencies added: base, mtl

Files

• COPYING +1/−0
• INSTALL +30/−0
• README +142/−0
• Setup.hs +2/−0
• StrategyLib.cabal +31/−0
• TODO +2/−0
• library/Control/Monad/Maybe.hs +106/−0
• library/Control/Monad/Run.hs +193/−0
• library/Data/Generics/Strafunski/StrategyLib/ChaseImports.hs +132/−0
• library/Data/Generics/Strafunski/StrategyLib/ContainerTheme.hs +175/−0
• library/Data/Generics/Strafunski/StrategyLib/EffectTheme.hs +179/−0
• library/Data/Generics/Strafunski/StrategyLib/FixpointTheme.hs +59/−0
• library/Data/Generics/Strafunski/StrategyLib/FlowTheme.hs +194/−0
• library/Data/Generics/Strafunski/StrategyLib/KeyholeTheme.hs +115/−0
• library/Data/Generics/Strafunski/StrategyLib/MetricsTheme.hs +106/−0
• library/Data/Generics/Strafunski/StrategyLib/MonadicFunctions.hs +80/−0
• library/Data/Generics/Strafunski/StrategyLib/NameTheme.hs +74/−0
• library/Data/Generics/Strafunski/StrategyLib/OverloadingTheme.hs +144/−0
• library/Data/Generics/Strafunski/StrategyLib/PathTheme.hs +83/−0
• library/Data/Generics/Strafunski/StrategyLib/RefactoringTheme.hs +150/−0
• library/Data/Generics/Strafunski/StrategyLib/StrategyInfix.hs +49/−0
• library/Data/Generics/Strafunski/StrategyLib/StrategyPrelude.hs +117/−0
• library/Data/Generics/Strafunski/StrategyLib/TraversalTheme.hs +190/−0
• models/deriving/Data/Generics/Strafunski/StrategyLib/StrategyPrimitives.hs +209/−0
• models/deriving/Data/Generics/Strafunski/StrategyLib/TermRep.hs +17/−0

@@ -0,0 +1,1 @@+See www.sourceforge.net/Strafunski

@@ -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.

@@ -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/+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks

@@ -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 <naesten@gmail.com>+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+        

@@ -0,0 +1,2 @@+- Omitted some examples compared to V3; more could still be added.+

@@ -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)))++------------------------------------------------------------------------------

@@ -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 ++------------------------------------------------------------------------------

@@ -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+++------------------------------------------------------------------------------

@@ -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++------------------------------------------------------------------------------

@@ -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)++     +------------------------------------------------------------------------------

@@ -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)))++------------------------------------------------------------------------------+

@@ -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)+++------------------------------------------------------------------------------

@@ -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))++------------------------------------------------------------------------------ 

@@ -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)++-------------------------------------------------------------------------------

@@ -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++------------------------------------------------------------------------------

@@ -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'++------------------------------------------------------------------------------ 

@@ -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    ++------------------------------------------------------------------------------

@@ -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++------------------------------------------------------------------------------+

@@ -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''++------------------------------------------------------------------------------

@@ -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+-}

@@ -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+++------------------------------------------------------------------------------

@@ -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+++------------------------------------------------------------------------------

@@ -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

@@ -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+