Strafunski-StrategyLib (empty) → 5.0.0.1
raw patch · 24 files changed
+2540/−0 lines, 24 filesdep +basedep +directorydep +mtlsetup-changed
Dependencies added: base, directory, mtl, syb
Files
- Control/Monad/Maybe.hs +105/−0
- Control/Monad/Run.hs +190/−0
- Data/Generics/Strafunski/StrategyLib/ChaseImports.hs +133/−0
- Data/Generics/Strafunski/StrategyLib/ContainerTheme.hs +175/−0
- Data/Generics/Strafunski/StrategyLib/EffectTheme.hs +177/−0
- Data/Generics/Strafunski/StrategyLib/FixpointTheme.hs +59/−0
- Data/Generics/Strafunski/StrategyLib/FlowTheme.hs +194/−0
- Data/Generics/Strafunski/StrategyLib/KeyholeTheme.hs +113/−0
- Data/Generics/Strafunski/StrategyLib/MetricsTheme.hs +107/−0
- Data/Generics/Strafunski/StrategyLib/Models/Deriving/StrategyPrimitives.hs +208/−0
- Data/Generics/Strafunski/StrategyLib/Models/Deriving/TermRep.hs +16/−0
- Data/Generics/Strafunski/StrategyLib/MonadicFunctions.hs +75/−0
- Data/Generics/Strafunski/StrategyLib/MoreMonoids.hs +24/−0
- Data/Generics/Strafunski/StrategyLib/NameTheme.hs +73/−0
- Data/Generics/Strafunski/StrategyLib/OverloadingTheme.hs +143/−0
- Data/Generics/Strafunski/StrategyLib/PathTheme.hs +83/−0
- Data/Generics/Strafunski/StrategyLib/RefactoringTheme.hs +149/−0
- Data/Generics/Strafunski/StrategyLib/StrategyInfix.hs +49/−0
- Data/Generics/Strafunski/StrategyLib/StrategyLib.hs +72/−0
- Data/Generics/Strafunski/StrategyLib/StrategyPrelude.hs +117/−0
- Data/Generics/Strafunski/StrategyLib/TraversalTheme.hs +190/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- Strafunski-StrategyLib.cabal +59/−0
+ Control/Monad/Maybe.hs view
@@ -0,0 +1,105 @@+------------------------------------------------------------------------------+-- | +-- Maintainer : 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.Fix+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)))++------------------------------------------------------------------------------
+ Control/Monad/Run.hs view
@@ -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 +-- 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 System.IO.Unsafe (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 ++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/ChaseImports.hs view
@@ -0,0 +1,133 @@+-- | +-- 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 hiding ( findFile )+import Control.Monad.Error () -- This import gives us (MonadPlus IO) !!+import Control.Exception+import System.IO+++------------------------------------------------------------------------------+-- * 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 :: String -> IO (Either IOException (String, String))+ 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+++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/ContainerTheme.hs view
@@ -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++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/EffectTheme.hs view
@@ -0,0 +1,177 @@+------------------------------------------------------------------------------ +-- | +-- 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.Run+import Control.Monad.Trans+import Data.Generics.Strafunski.StrategyLib.StrategyPrelude+import Data.Generics.Strafunski.StrategyLib.OverloadingTheme+import Data.Generics.Strafunski.StrategyLib.Models.Deriving.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)++ +------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/FixpointTheme.hs view
@@ -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 Control.Monad+import Data.Generics.Strafunski.StrategyLib.StrategyPrelude+import Data.Generics.Strafunski.StrategyLib.FlowTheme+import Data.Generics.Strafunski.StrategyLib.TraversalTheme+++------------------------------------------------------------------------------+-- * 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)))++------------------------------------------------------------------------------+
+ Data/Generics/Strafunski/StrategyLib/FlowTheme.hs view
@@ -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)+++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/KeyholeTheme.hs view
@@ -0,0 +1,113 @@+------------------------------------------------------------------------------+-- | +-- 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.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))++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/MetricsTheme.hs view
@@ -0,0 +1,107 @@+------------------------------------------------------------------------------+-- | +-- 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+type Metrics = MetricName -> Integer++-- | The type of metric names+type MetricName = String++-- | Create 'Metrics' with given initial value for all metrics.+initMetrics :: Integer -> Metrics+initMetrics n = \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 = \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 = putStrLn $ key++" = "++show (m key)++++-- * Metrics as monoids +instance Monoid Metrics where+ mempty = initMetrics0+ mappend m1 m2 = \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)++-------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/Models/Deriving/StrategyPrimitives.hs view
@@ -0,0 +1,208 @@+{-----------------------------------------------------------------------------++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.Models.Deriving.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.Models.Deriving.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
+ Data/Generics/Strafunski/StrategyLib/Models/Deriving/TermRep.hs view
@@ -0,0 +1,16 @@+-- +-- 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.Models.Deriving.TermRep (+ Term+) where++import Data.Generics++class Data x => Term x++instance (Typeable x, Data x) => Term x+
+ Data/Generics/Strafunski/StrategyLib/MonadicFunctions.hs view
@@ -0,0 +1,75 @@+------------------------------------------------------------------------------+-- | +-- 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++------------------------------------------------------------------------------+-- * 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+++------------------------------------------------------------------------------+-- * 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++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/MoreMonoids.hs view
@@ -0,0 +1,24 @@+------------------------------------------------------------------------------+-- | +-- 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 additional instances of the Monoid class.++------------------------------------------------------------------------------++module Data.Generics.Strafunski.StrategyLib.MoreMonoids where++import Data.Monoid++------------------------------------------------------------------------------++-- | Any 'Num' is a 'Monoid'.+instance Num a => Monoid a where+ mempty = 0+ mappend = (+)++-----------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/NameTheme.hs view
@@ -0,0 +1,73 @@+------------------------------------------------------------------------------+-- | +-- 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 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'++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/OverloadingTheme.hs view
@@ -0,0 +1,143 @@+------------------------------------------------------------------------------+-- | +-- 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 ++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/PathTheme.hs view
@@ -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 Control.Monad+import Data.Generics.Strafunski.StrategyLib.StrategyPrelude+import Data.Generics.Strafunski.StrategyLib.OverloadingTheme+import Data.Generics.Strafunski.StrategyLib.FlowTheme+import Data.Generics.Strafunski.StrategyLib.TraversalTheme+++------------------------------------------------------------------------------+-- * 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++------------------------------------------------------------------------------+
+ Data/Generics/Strafunski/StrategyLib/RefactoringTheme.hs view
@@ -0,0 +1,149 @@+------------------------------------------------------------------------------+-- | +-- 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''++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/StrategyInfix.hs view
@@ -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+-}
+ Data/Generics/Strafunski/StrategyLib/StrategyLib.hs view
@@ -0,0 +1,72 @@+------------------------------------------------------------------------------ +-- | +-- 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 is the+-- top-level module of the library. One only needs to import this module to+-- use the entire library. Some base modules are exported as well because+-- they are commonly used.++------------------------------------------------------------------------------ ++module Data.Generics.Strafunski.StrategyLib.StrategyLib (++ module Control.Monad,+ module Control.Monad.Fix,+ module Control.Monad.Trans,+ Identity(..),+-- MaybeT(..),+ State(..),+ StateT(..),+ module Data.Monoid,+ module Data.Generics.Strafunski.StrategyLib.MoreMonoids,++ module Data.Generics.Strafunski.StrategyLib.StrategyPrelude,+ module Data.Generics.Strafunski.StrategyLib.StrategyInfix,++ module Data.Generics.Strafunski.StrategyLib.OverloadingTheme,+ module Data.Generics.Strafunski.StrategyLib.TraversalTheme,+ module Data.Generics.Strafunski.StrategyLib.FlowTheme,+ module Data.Generics.Strafunski.StrategyLib.FixpointTheme,+ module Data.Generics.Strafunski.StrategyLib.KeyholeTheme,+ module Data.Generics.Strafunski.StrategyLib.NameTheme,+ module Data.Generics.Strafunski.StrategyLib.PathTheme,+ module Data.Generics.Strafunski.StrategyLib.EffectTheme,+ module Data.Generics.Strafunski.StrategyLib.ContainerTheme,+ module Data.Generics.Strafunski.StrategyLib.RefactoringTheme,+ module Data.Generics.Strafunski.StrategyLib.MetricsTheme,+ + module Data.Generics.Strafunski.StrategyLib.ChaseImports++) where++import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans+import Control.Monad.Identity+import Control.Monad.Maybe+import Control.Monad.State+import Data.Monoid+import Data.Generics.Strafunski.StrategyLib.MoreMonoids++import Data.Generics.Strafunski.StrategyLib.StrategyPrelude+import Data.Generics.Strafunski.StrategyLib.StrategyInfix++import Data.Generics.Strafunski.StrategyLib.OverloadingTheme+import Data.Generics.Strafunski.StrategyLib.FixpointTheme+import Data.Generics.Strafunski.StrategyLib.PathTheme+import Data.Generics.Strafunski.StrategyLib.NameTheme+import Data.Generics.Strafunski.StrategyLib.KeyholeTheme+import Data.Generics.Strafunski.StrategyLib.EffectTheme+import Data.Generics.Strafunski.StrategyLib.ContainerTheme hiding (modify)+import Data.Generics.Strafunski.StrategyLib.FlowTheme+import Data.Generics.Strafunski.StrategyLib.TraversalTheme+import Data.Generics.Strafunski.StrategyLib.RefactoringTheme+import Data.Generics.Strafunski.StrategyLib.MetricsTheme++import Data.Generics.Strafunski.StrategyLib.ChaseImports++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/StrategyPrelude.hs view
@@ -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.Models.Deriving.StrategyPrimitives,+ module Data.Generics.Strafunski.StrategyLib.StrategyPrelude+) where++import Data.Generics.Strafunski.StrategyLib.Models.Deriving.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+++------------------------------------------------------------------------------
+ Data/Generics/Strafunski/StrategyLib/TraversalTheme.hs view
@@ -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+++------------------------------------------------------------------------------
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2002 - 2013 Ralf Laemmel, Joost Visser++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Strafunski-StrategyLib.cabal view
@@ -0,0 +1,59 @@+name: Strafunski-StrategyLib+version: 5.0.0.1+synopsis: Library for strategic programming+description: This is a version of the StrategyLib library originally shipped with Strafunski, Cabalized and updated to newer versions of GHC. A description of much of StrategyLib can be found in the paper "Design Patterns for Functional Strategic Programming."+license: BSD3+license-file: LICENSE+author: Ralf Laemmel, Joost Visser+maintainer: darmanithird@gmail.com+category: Generics+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: https://github.com/jkoppel/Strafunski-StrategyLib+++library++ Extensions:+ OverlappingInstances,+ FlexibleInstances,+ FlexibleContexts,+ UndecidableInstances,+ MultiParamTypeClasses,+ FunctionalDependencies,+ Rank2Types++ exposed-modules:+ Control.Monad.Maybe,+ Control.Monad.Run,+ 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,+ Data.Generics.Strafunski.StrategyLib.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.StrategyLib,+ Data.Generics.Strafunski.StrategyLib.StrategyPrelude,+ Data.Generics.Strafunski.StrategyLib.TraversalTheme,+ Data.Generics.Strafunski.StrategyLib.Models.Deriving.StrategyPrimitives,+ Data.Generics.Strafunski.StrategyLib.Models.Deriving.TermRep+ +-- other-modules: ++ build-depends:+ base ==4.5.*,+ mtl ==2.1.*,+ syb ==0.3.*,+ directory ==1.2.*+