uniplate 1.5.1 → 1.6.13
raw patch · 27 files changed
Files
- CHANGES.txt +57/−0
- Data/Generics/Biplate.hs +8/−8
- Data/Generics/Compos.hs +1/−2
- Data/Generics/PlateData.hs +9/−68
- Data/Generics/PlateDirect.hs +7/−8
- Data/Generics/PlateInternal.hs +0/−78
- Data/Generics/PlateTypeable.hs +9/−9
- Data/Generics/SYB.hs +4/−3
- Data/Generics/Str.hs +37/−15
- Data/Generics/Uniplate.hs +5/−7
- Data/Generics/Uniplate/Data.hs +23/−2
- Data/Generics/Uniplate/Data/Instances.hs +273/−0
- Data/Generics/Uniplate/DataOnly.hs +3/−1
- Data/Generics/Uniplate/Direct.hs +42/−11
- Data/Generics/Uniplate/Internal/Data.hs +197/−164
- Data/Generics/Uniplate/Internal/DataInc.hs +5/−0
- Data/Generics/Uniplate/Internal/OperationsInc.hs +49/−38
- Data/Generics/Uniplate/Internal/Utils.hs +7/−19
- Data/Generics/Uniplate/Typeable.hs +1/−0
- Data/Generics/Uniplate/Zipper.hs +157/−0
- Data/Generics/UniplateOn.hs +2/−4
- Data/Generics/UniplateStr.hs +6/−6
- Data/Generics/UniplateStrOn.hs +5/−4
- LICENSE +1/−1
- README.md +236/−0
- uniplate.cabal +37/−29
- uniplate.htm +0/−265
+ CHANGES.txt view
@@ -0,0 +1,57 @@+Changelog for Uniplate++1.6.13, released 2020-11-07+ Remove support from pre-GHC 8.0+ #31, GHC 9.0 compatibility+ Change descendM to be applicative, not monadic+1.6.12, released 2013-10-26+ Allow compilation with clang+1.6.11, released 2013-08-14+ Work around more excessive strictness, gives 10x speed improvement+1.6.10, released 2012-12-14+ Allow hashable-1.2+ Work around excessive strictness in unordered-containers-0.2.3.0+1.6.9, released 2012-12-08+ Remove dependencies on an old internal module+ More performance work (speculative)+1.6.8, released 2012-12-05+ Significant speed up to default descend/descendM versions+ Implement faster descendM/descendBiM for the Data version+ Add RULES for the Direct method which follow plate identities+ Disallow unordered-containers 0.2.0.*+1.6.7, released 2012-03-08+ Allow unordered-containers 0.2.*+1.6.6, released 2012-02-15+ Require hashable-1.1.2.3, which has a TypeRep instance+1.6.5, released 2011-11-05+ Add more instances for the Data.Instances, such as Ord/Eq+1.6.4, released 2011-11-05+ Give better Data instances for the containers package+1.6.3, released 2011-10-11+ #454, use unordered-containers on GHC 7.2 and above (faster)+1.6.2, released 2011-08-16+ Given a Map/Set (or anything with NorepType) ignore it+ Add $UNIPLATE_VERBOSE to give messages about cache construction+1.6.1, released 2011-08-11+ #435, mark things that were recommended not to use as deprecated+ #449, GHC 7.2 compatibility+1.6, released 2010-11-10+ GHC 7 compatibility+ Eliminate mtl dependency+ Add transformer/transformBis, along with better documentation+ #364, add a zipper in Data.Generics.Uniplate.Zipper+ Add an Eq instance for Str+1.5.1, released 2010-01-24+ Fix a typo in the synopsis+1.5, released 2010-01-23+ Massive speed improvements to Data loading initial cache+1.4, released 2010-01-12+ Add back performance enhancement for Rationals+1.3, released 2010-01-03+ Rewrite, simplify, roll out Data.Generics.Uniplate.*+1.2, released 2008-07-08+ Allow Data operations to work on Rational+1.1, not on Hackage+ Add versions based on Str+1.0, released 2007-06-13+ Initial release
Data/Generics/Biplate.hs view
@@ -1,32 +1,32 @@-{-# OPTIONS_GHC -fglasgow-exts #-} {-# LANGUAGE MultiParamTypeClasses #-} {- |- /RECOMMENDATION/: Use "Data.Generics.Uniplate.Operations" instead.+ /DEPRECATED/: Use "Data.Generics.Uniplate.Operations" instead. Requires multi-parameter type classes, so is no longer Haskell 98. These operations are easier to use and construct than the equivalent "Data.Generics.UniplateStrOn" methods, but perform the same operation.- + It is recommended that instead of importing this module, you import one of the following modules, to construct instances:- + * "Data.Generics.PlateDirect" - does not require overlapping instances, highest performance but requires /O(n^2)/ instances in the worst case.- + * "Data.Generics.PlateTypeable" - requires the "Data.Typeable" class for all data structures.- + * "Data.Generics.PlateData" - requires "Data.Generics" and the 'Data' class, which is only available on GHC, but automatically infers instances. -} -module Data.Generics.Biplate(+module Data.Generics.Biplate+ {- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -}+ ( module Data.Generics.UniplateStrOn, module Data.Generics.Biplate ) where import Data.Generics.UniplateStrOn-import Data.Generics.Str -- * The Class
Data/Generics/Compos.hs view
@@ -16,7 +16,6 @@ module Data.Generics.Compos where import Control.Monad-import Data.Monoid import Data.Generics.Uniplate.Operations @@ -30,7 +29,7 @@ -- | @composOpM == 'descendM'@-composOpM :: (Uniplate a, Monad m) => (a -> m a) -> a -> m a+composOpM :: (Uniplate a, Applicative m) => (a -> m a) -> a -> m a composOpM = descendM
Data/Generics/PlateData.hs view
@@ -1,34 +1,26 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, ExistentialQuantification, Rank2Types, CPP #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, ExistentialQuantification, Rank2Types #-}+{-# OPTIONS_GHC -Wno-orphans #-} {- |- /RECOMMENDATION/: Use "Data.Generics.Uniplate.Data" instead.+ /DEPRECATED/: Use "Data.Generics.Uniplate.Data" instead. This module exports 'Biplate' instances for everything with 'Data' defined. Using GHC the 'Data' instances can be constructed with @deriving Data@. -}-module Data.Generics.PlateData(+module Data.Generics.PlateData+ {-# DEPRECATED "Use Data.Generics.Uniplate.Data instead" #-}+ ( module Data.Generics.Biplate ) where import Data.Generics.Biplate-import Data.Generics.PlateInternal-import Data.Generics.Str+import Data.Generics.Uniplate.Internal.Utils import Data.Generics-import Data.Maybe-import Data.List-import qualified Data.IntSet as IntSet-import Control.Monad.State-import Data.Ratio ---- | An existential box representing a type which supports SYB--- operations.-data DataBox = forall a . (Typeable a, Data a) => DataBox a- data Box find = Box {fromBox :: forall a . Typeable a => a -> Answer find} -data Answer a = Hit {fromHit :: a} -- you just hit the element you were after (here is a cast)+data Answer a = Hit {_fromHit :: a} -- you just hit the element you were after (here is a cast) | Follow -- go forward, you will find something | Miss -- you failed to sink my battleship! @@ -38,7 +30,6 @@ start -> find -> Box find -#if __GLASGOW_HASKELL__ < 606 -- GHC 6.4.2 does not export typeRepKey, so we can't do the trick -- as efficiently, so we just give up and revert to always following @@ -48,57 +39,7 @@ Just y -> Hit y Nothing -> Follow -#else--- GHC 6.6 does contain typeRepKey, so only follow when appropriate -containsMatch start find = Box query- where- typeInt x = inlinePerformIO $ typeRepKey x- - query :: Typeable a => a -> Answer find- query a = if tifind == tia then Hit (unsafeCast a)- else if tia `IntSet.member` timatch then Follow else Miss- where tia = typeInt $ typeOf a- - tifind = typeInt tfind- timatch = IntSet.fromList $ map typeInt tmatch-- tfind = typeOf find- tmatch = f [tfind] (filter ((/=) tfind . fst) $ containsList start)-- f want have = if null want2 then [] else want2 ++ f want2 no- where- want2 = map fst yes- (yes,no) = partition (not . null . intersect want . snd) have--containsList :: (Data a, Typeable a) => a -> [(TypeRep, [TypeRep])]-containsList x = f [] [DataBox x]- where- f done [] = []- f done (DataBox t:odo)- | tt `elem` done = f done odo- | otherwise = (tt,map (\(DataBox a) -> typeOf a) xs) : f (tt:done) (xs++odo)- where- tt = typeOf t- xs = contains t----- Ratio is strict and causes bugs with fromConstr in GHC 6.10.1--- See bug http://hackage.haskell.org/trac/ghc/ticket/2782-evilRatio = fst $ splitTyConApp $ typeOf (undefined :: Ratio Int) --contains :: (Data a, Typeable a) => a -> [DataBox]-contains x | fst (splitTyConApp $ typeOf x) == evilRatio = []- | isAlgType dtyp = concatMap f ctrs- | otherwise = []- where- f ctr = gmapQ DataBox (asTypeOf (fromConstr ctr) x)- ctrs = dataTypeConstrs dtyp- dtyp = dataTypeOf x--#endif-- instance (Data a, Typeable a) => Uniplate a where uniplate = collect_generate (fromBox answer) where@@ -123,7 +64,7 @@ collect_generate_self oracle x = res where res = case oracle x of- Hit y -> (One y, \(One x) -> unsafeCast x)+ Hit y -> (One y, \(One x) -> unsafeCoerce x) Follow -> collect_generate oracle x Miss -> (Zero, \_ -> x)
Data/Generics/PlateDirect.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {- |- /RECOMMENDATION/: Use "Data.Generics.Uniplate.Direct" instead.+ /DEPRECATED/: Use "Data.Generics.Uniplate.Direct" instead. This module supplies a method for writing 'Biplate' instances more easily. This module requires fewest extensions, highest performance, and most instance definitions.- + To take an example:- + > data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr > data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr >@@ -34,9 +34,11 @@ > biplate (Sel x ) = plate Sel ||* x > biplate (Let x y) = plate Let |- x |* y -}- -module Data.Generics.PlateDirect(++module Data.Generics.PlateDirect+ {-# DEPRECATED "Use Data.Generics.Uniplate.Direct instead" #-}+ ( module Data.Generics.Biplate, -- * The Combinators plate, plateSelf,@@ -44,9 +46,6 @@ ) where import Data.Generics.Biplate-import Data.Generics.PlateInternal-import Data.Generics.Str-import Data.Maybe type Type from to = (Str to, Str to -> from)
− Data/Generics/PlateInternal.hs
@@ -1,78 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-{-# LANGUAGE CPP, Rank2Types #-}--{- |- Internal module, do not import or use.--}--module Data.Generics.PlateInternal(- unsafeCast, inlinePerformIO, builder, concatCont- ) where--------------------------------------------------------------------------- GHC-{--#if !__GLASGOW_HASKELL__-{--#endif--}--import GHC.Exts(unsafeCoerce#, build, realWorld#)-import GHC.IOBase(IO(IO))--{-# INLINE unsafeCast #-}--- | @unsafeCoerce@, but for all compilers. In future this can be obtained from--- @Unsafe.Coerce.unsafeCoerce@, but thats too recent a change.-unsafeCast :: a -> b-unsafeCast = unsafeCoerce#--{-# INLINE builder #-}--- | GHCs @foldr@\/@build@ system, but on all platforms-builder :: forall a . (forall b . (a -> b -> b) -> b -> b) -> [a]-builder = build--{-# INLINE inlinePerformIO #-}--- | 'unsafePerformIO', but suitable for inlining. Copied from "Data.ByteString.Base".-inlinePerformIO :: IO a -> a-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r--{--#if !__GLASGOW_HASKELL__--}-#endif--}---------------------------------------------------------------------------- !GHC-{--#if !__GLASGOW_HASKELL__--}--import Data.Typeable-import Data.Maybe-import Foreign--unsafeCast :: (Typeable a, Typeable b) => a -> b-unsafeCast = fromJust . cast--inlinePerformIO :: IO a -> a-inlinePerformIO = unsafePerformIO--builder :: ((x -> [x] -> [x]) -> [x] -> [x]) -> [x]-builder f = f (:) []--{--#endif--}-----{-# INLINE concatCont #-}--- | Perform concatentation of continuations-concatCont :: [a -> a] -> a -> a-concatCont xs rest = foldr ($) rest xs-
Data/Generics/PlateTypeable.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} {- |- /RECOMMENDATION/: Use "Data.Generics.Uniplate.Typeable" instead.+ /DEPRECATED/: Use "Data.Generics.Uniplate.Typeable" instead. This module supplies a method for writing 'Biplate' instances more easily.- + To take an example:- + > data Expr = Var Int | Neg Expr | Add Expr Expr > > instance Typeable Expr where ...@@ -20,7 +21,9 @@ > uniplate = uniplateAll -} -module Data.Generics.PlateTypeable(+module Data.Generics.PlateTypeable+ {-# DEPRECATED "Use Data.Generics.Uniplate.Typeable instead" #-}+ ( module Data.Generics.Biplate, module Data.Typeable, -- * The Class@@ -30,10 +33,8 @@ ) where import Data.Generics.Biplate-import Data.Generics.PlateInternal-import Data.Generics.Str+import Data.Generics.Uniplate.Internal.Utils import Data.Typeable-import Data.Maybe instance (Typeable a, Typeable b, Uniplate b, PlateAll a b) => Biplate a b where@@ -53,7 +54,7 @@ where res = case asTypeOf (cast x) (Just $ strType $ fst res) of Nothing -> plateAll x- Just y -> (One y, \(One y) -> unsafeCast y)+ Just y -> (One y, \(One y) -> unsafeCoerce y) -- | This class represents going from the container type to the target.@@ -153,4 +154,3 @@ ,Typeable to, Uniplate to) => PlateAll (a,b,c,d,e) to where plateAll (a,b,c,d,e) = plate (,,,,) |+ a |+ b |+ c |+ d |+ e-
Data/Generics/SYB.hs view
@@ -18,6 +18,7 @@ import Data.Generics.Uniplate.Operations + -- | @gmapT == 'descend'@ gmapT :: Uniplate a => (a -> a) -> a -> a gmapT = descend@@ -44,7 +45,7 @@ -- | @gmapM == 'descendM'@-gmapM :: (Uniplate a, Monad m) => (a -> m a) -> a -> m a+gmapM :: (Uniplate a, Applicative m) => (a -> m a) -> a -> m a gmapM = descendM @@ -60,12 +61,12 @@ -- | @mkM == id@-mkM :: Monad m => (a -> m a) -> a -> m a+mkM :: (a -> m a) -> a -> m a mkM = id -- | @everywhereM == 'transformBiM'@-everywhereM :: (Biplate b a, Monad m) => (a -> m a) -> b -> m b+everywhereM :: (Biplate b a, Monad m, Applicative m) => (a -> m a) -> b -> m b everywhereM = transformBiM
Data/Generics/Str.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {- | This module provides the 'Str' data type, which is used by the underlying 'uniplate' and 'biplate' methods. It should not@@ -6,35 +7,56 @@ module Data.Generics.Str where -import Data.Generics.PlateInternal--import Data.Traversable-import Data.Foldable-import Control.Applicative-import Data.Monoid+import Data.Generics.Uniplate.Internal.Utils -- * The Data Type data Str a = Zero | One a | Two (Str a) (Str a) deriving Show +instance Eq a => Eq (Str a) where+ Zero == Zero = True+ One x == One y = x == y+ Two x1 x2 == Two y1 y2 = x1 == y1 && x2 == y2+ _ == _ = False ++{-# INLINE strMap #-}+strMap :: (a -> b) -> Str a -> Str b+strMap f x = g SPEC x+ where+ g !spec Zero = Zero+ g !spec (One x) = One $ f x+ g !spec (Two x y) = Two (g spec x) (g spec y)++++{-# INLINE strMapM #-}+strMapM :: Applicative m => (a -> m b) -> Str a -> m (Str b)+strMapM f x = g SPEC x+ where+ g !spec Zero = pure Zero+ g !spec (One x) = One <$> f x+ g !spec (Two x y) = Two <$> g spec x <*> g spec y++ instance Functor Str where- fmap f Zero = Zero- fmap f (One x) = One (f x)- fmap f (Two x y) = Two (fmap f x) (fmap f y)+ fmap f Zero = Zero+ fmap f (One x) = One (f x)+ fmap f (Two x y) = Two (fmap f x) (fmap f y) + instance Foldable Str where- foldMap m Zero = mempty- foldMap m (One x) = m x- foldMap m (Two l r) = foldMap m l `mappend` foldMap m r+ foldMap m Zero = mempty+ foldMap m (One x) = m x+ foldMap m (Two l r) = foldMap m l `mappend` foldMap m r instance Traversable Str where- traverse f Zero = pure Zero- traverse f (One x) = One <$> f x- traverse f (Two x y) = Two <$> traverse f x <*> traverse f y+ traverse f Zero = pure Zero+ traverse f (One x) = One <$> f x+ traverse f (Two x y) = Two <$> traverse f x <*> traverse f y -- | Take the type of the method, will crash if called
Data/Generics/Uniplate.hs view
@@ -1,5 +1,5 @@ {- |-/RECOMMENDATION/ Use "Data.Generics.UniplateStr" instead.+/DEPRECATED/ Use "Data.Generics.Uniplate.Operations" instead. This is the main Uniplate module, which defines all the essential operations in a Haskell 98 compatible manner.@@ -14,12 +14,11 @@ module Data.Generics.Uniplate- {- DEPRECATED "Use Data.Generics.UniplateStr instead" -}+ {- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -} where import Control.Monad-import Data.List(inits,tails)-import Data.Generics.PlateInternal+import Data.Generics.Uniplate.Internal.Utils -- * The Class@@ -37,7 +36,7 @@ -- > uniplate (Add (Val 1) (Neg (Val 2))) = ([Val 1, Neg (Val 2)], \[a,b] -> Add a b) -- > uniplate (Val 1) = ([] , \[] -> Val 1 ) uniplate :: UniplateType on- + -- * The Operations -- ** Queries@@ -113,7 +112,7 @@ where (current, generate) = uniplate x --- | Monadic variant of 'descend' +-- | Monadic variant of 'descend' descendM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on descendM f x = liftM generate $ mapM f current where (current, generate) = uniplate x@@ -149,4 +148,3 @@ -- technically a paramorphism para :: Uniplate on => (on -> [r] -> r) -> on -> r para op x = op x $ map (para op) $ children x-
Data/Generics/Uniplate/Data.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, Rank2Types, CPP, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} {- | This module defines 'Uniplate' / 'Biplate' instances for every type with a@@ -9,14 +10,34 @@ > deriving (Data,Typeable) All the Uniplate operations defined in "Data.Generics.Uniplate.Operations"- can be used.+ can be used. If you are working with abstract data types, such as @Map@ or @Set@+ from the @containers@ package, you may also need to use the data types defined+ in "Data.Generics.Uniplate.Data.Instances". For faster performance (5x faster, but requires writing instances) switch to "Data.Generics.Uniplate.Direct". If you get instance conflicts when using both @Data@ and @Direct@, switch to "Data.Generics.Uniplate.DataOnly".++ The instances are faster than GHC because they precompute a table of useful information,+ then use this information when performing the traversals. Sometimes it is not possible+ to compute the table, in which case this library will perform about the same speed as+ SYB.++ Setting the environment variable @$UNIPLATE_VERBOSE@ has the following effects:++ * @-1@ - raise a program error every time construction of the table fails++ * @0@ (or unset) - never print any messages or raise any errors++ * @1@ - give a message every time a table is computed++ * @2@ - give a message when table computation fails++ The @$UNIPLATE_VERBOSE@ environment variable must be set before the first call to uniplate. -} module Data.Generics.Uniplate.Data(- module Data.Generics.Uniplate.Operations+ module Data.Generics.Uniplate.Operations,+ transformBis, Transformer, transformer ) where import Data.Generics.Uniplate.Operations
+ Data/Generics/Uniplate/Data/Instances.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | In some cases, 'Data' instances for abstract types are incorrect,+-- and fail to work correctly with Uniplate. This module defines three helper+-- types ('Hide', 'Trigger' and 'Invariant') to assist when writing instances+-- for abstract types. The 'Hide' type is useful when you want to mark some part+-- of your data type as being ignored by "Data.Generics.Uniplate.Data"+-- (and any other 'Data' based generics libraries, such as @syb@).+--+-- Using the helper types, this module defines wrappers for types in+-- the @containers@ package, namely 'Map', 'Set', 'IntMap' and 'IntSet'.+-- The standard @containers@ 'Data' instances all treat the types as abstract,+-- but the wrapper types allow you to traverse within the data types, ensuring+-- the necessary invariants are maintained. In particular, if you do not modify+-- the keys reconstruct will be /O(n)/ instead of /O(n log n)/.+--+-- As an example of how to implement your own abstract type wrappers, the 'Map' data+-- type is defined as:+--+-- @+-- newtype Map k v = Map ('Invariant' ('Trigger' [k], 'Trigger' [v], Hide (Map.Map k v)))+-- deriving (Data, Typeable)+-- @+--+-- The 'Map' type is defined as an 'Invariant' of three components - the keys, the values, and+-- the underlying @Map@. We use 'Invariant' to ensure that the keys/values/map always remain in sync.+-- We use 'Trigger' on the keys and values to ensure that whenever the keys or values change we+-- rebuild the @Map@, but if they don't, we reuse the previous @Map@. The 'fromMap' function is+-- implemented by pattern matching on the 'Map' type:+--+-- @+-- 'fromMap' ('Map' ('Invariant' _ (_,_,'Hide' x))) = x+-- @+--+-- The 'toMap' function is slightly harder, as we need to come up with an invariant restoring function:+--+-- > toMap :: Ord k => Map.Map k v -> Map k v+-- > toMap x = Map $ Invariant inv $ create x+-- > where+-- > create x = (Trigger False ks, Trigger False vs, Hide x)+-- > where (ks,vs) = unzip $ Map.toAscList x+-- >+-- > inv (ks,vs,x)+-- > | trigger ks = create $ Map.fromList $ zip (fromTrigger ks) (fromTrigger vs)+-- > | trigger vs = create $ Map.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs)+-- > | otherwise = (ks,vs,x)+--+-- The 'create' function creates a value from a @Map@, getting the correct keys and values. The 'inv'+-- function looks at the triggers on the keys/values. If the keys trigger has been tripped, then we+-- reconstruct the @Map@ using @fromList@. If the values trigger has been tripped, but they keys trigger+-- has not, we can use @fromDistinctAscList@, reducing the complexity of constructing the @Map@. If nothing+-- has changed we can reuse the previous value.+--+-- The end result is that all Uniplate (or @syb@) traversals over 'Map' result in a valid value, which has+-- had all appropriate transformations applied.+module Data.Generics.Uniplate.Data.Instances(+ Hide(..), Trigger(..), Invariant(..),+ Map, fromMap, toMap,+ Set, fromSet, toSet,+ IntMap, fromIntMap, toIntMap,+ IntSet, fromIntSet, toIntSet+ ) where++import Data.Data+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+++---------------------------------------------------------------------+-- DATA TYPES++-- | The 'Hide' data type has a 'Data' instance which reports having no constructors,+-- as though the type was defined as using the extension @EmptyDataDecls@:+--+-- > data Hide a+--+-- This type is suitable for defining regions that are avoided by Uniplate traversals.+-- As an example:+--+-- > transformBi (+1) (1, 2, Hide 3, Just 4) == (2, 3, Hide 3, Just 4)+--+-- As a result of having no constructors, any calls to the methods 'toConstr' or 'gunfold'+-- will raise an error.+newtype Hide a = Hide {fromHide :: a}+ deriving (Read,Ord,Eq,Typeable)++instance Show a => Show (Hide a) where+ show (Hide a) = "Hide " ++ show a++instance Functor Hide where+ fmap f (Hide x) = Hide $ f x+++instance Typeable a => Data (Hide a) where+ gfoldl k z x = z x+ gunfold k z c = error "Data.Generics.Uniplate.Data.Instances.Hide: gunfold not implemented - data type has no constructors"+ toConstr _ = error "Data.Generics.Uniplate.Data.Instances.Hide: toConstr not implemented - data type has no constructors"+ dataTypeOf _ = tyHide++tyHide = mkDataType "Data.Generics.Uniplate.Data.Instances.Hide" []+++-- | The 'Trigger' data type has a 'Data' instance which reports as being defined:+--+-- > data Trigger a = Trigger a+--+-- However, whenever a 'gfoldl' or 'gunfold' constructs a new value, it will have the+-- 'trigger' field set to 'True'. The trigger information is useful to indicate whether+-- any invariants have been broken, and thus need fixing. As an example:+--+-- > data SortedList a = SortedList (Trigger [a]) deriving (Data,Typeable)+-- > toSortedList xs = SortedList $ Trigger False $ sort xs+-- > fromSortedList (SortedList (Trigger t xs)) = if t then sort xs else xs+--+-- This data type represents a sorted list. When constructed the items are initially sorted,+-- but operations such as 'gmapT' could break that invariant. The 'Trigger' type is used to+-- detect when the Data operations have been performed, and resort the list.+--+-- The 'Trigger' type is often used in conjunction with 'Invariant', which fixes the invariants.+data Trigger a = Trigger {trigger :: Bool, fromTrigger :: a}+ deriving (Read,Ord,Eq,Show,Typeable)++instance Functor Trigger where+ fmap f (Trigger a b) = Trigger a $ f b+++instance (Data a, Typeable a) => Data (Trigger a) where+ gfoldl k z (Trigger _ x) = z (Trigger True) `k` x+ gunfold k z c = k $ z $ Trigger True+ toConstr Trigger{} = conTrigger+ dataTypeOf _ = tyTrigger++conTrigger = mkConstr tyTrigger "Trigger" [] Prefix+tyTrigger = mkDataType "Data.Generics.Uniplate.Data.Instances.Trigger" [conTrigger]+++-- | The 'Invariant' data type as a 'Data' instance which reports as being defined:+--+-- > data Invariant a = Invariant a+--+-- However, whenever a 'gfoldl' constructs a new value, it will have the function in+-- the 'invariant' field applied to it. As an example:+--+-- > data SortedList a = SortedList (Invariant [a]) deriving (Data,Typeable)+-- > toSortedList xs = SortedList $ Invariant sort (sort xs)+-- > fromSortedList (SortedList (Invariant _ xs)) = xs+--+-- Any time an operation such as 'gmapT' is applied to the data type, the 'invariant' function+-- is applied to the result. The @fromSortedList@ function can then rely on this invariant.+--+-- The 'gunfold' method is partially implemented - all constructed values will have an undefined+-- value for all fields, regardless of which function is passed to 'fromConstrB'. If you only use+-- 'fromConstr' (as Uniplate does) then the 'gunfold' method is sufficient.+data Invariant a = Invariant {invariant :: a -> a, fromInvariant :: a}+ deriving Typeable++instance Show a => Show (Invariant a) where+ show (Invariant _ x) = "Invariant " ++ show x++instance (Data a, Typeable a) => Data (Invariant a) where+ gfoldl k z (Invariant f x) = z (Invariant f . f) `k` x+ gunfold k z c = k $ z $ \x -> Invariant (error msg) (error msg `asTypeOf` x)+ where msg = "Data.Generics.Uniplate.Data.Instances.Invariant: gunfold only partially implemented"+ toConstr Invariant{} = conInvariant+ dataTypeOf _ = tyInvariant++conInvariant = mkConstr tyInvariant "Invariant" [] Prefix+tyInvariant = mkDataType "Data.Generics.Uniplate.Data.Instances.Invariant" [conInvariant]+++---------------------------------------------------------------------+-- DATA TYPES++-- | Invariant preserving version of @Map@ from the @containers@ packages, suitable for use with 'Uniplate'.+-- Use 'toMap' to construct values, and 'fromMap' to deconstruct values.+newtype Map k v = Map (Invariant (Trigger [k], Trigger [v], Hide (Map.Map k v)))+ deriving (Data, Typeable)++instance (Show k, Show v) => Show (Map k v) where; show = show . fromMap+instance (Eq k, Eq v) => Eq (Map k v) where; a == b = fromMap a == fromMap b+instance (Ord k, Ord v) => Ord (Map k v) where; compare a b = compare (fromMap a) (fromMap b)++-- | Deconstruct a value of type 'Map'.+fromMap :: Map k v -> Map.Map k v+fromMap (Map (Invariant _ (_,_,Hide x))) = x++-- | Construct a value of type 'Map'.+toMap :: Ord k => Map.Map k v -> Map k v+toMap x = Map $ Invariant inv $ create x+ where+ create x = (Trigger False ks, Trigger False vs, Hide x)+ where (ks,vs) = unzip $ Map.toAscList x++ inv (ks,vs,x)+ | trigger ks = create $ Map.fromList $ zip (fromTrigger ks) (fromTrigger vs)+ | trigger vs = create $ Map.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs) -- recreate ks/vs to reduce memory usage+ | otherwise = (ks,vs,x)+++-- | Invariant preserving version of @Set@ from the @containers@ packages, suitable for use with 'Uniplate'.+-- Use 'toSet' to construct values, and 'fromSet' to deconstruct values.+newtype Set k = Set (Invariant (Trigger [k], Hide (Set.Set k)))+ deriving (Data, Typeable)++instance Show k => Show (Set k) where; show = show . fromSet+instance Eq k => Eq (Set k) where; a == b = fromSet a == fromSet b+instance Ord k => Ord (Set k) where; compare a b = compare (fromSet a) (fromSet b)++-- | Deconstruct a value of type 'Set'.+fromSet :: Set k -> Set.Set k+fromSet (Set (Invariant _ (_,Hide x))) = x++-- | Construct a value of type 'Set'.+toSet :: Ord k => Set.Set k -> Set k+toSet x = Set $ Invariant inv $ create x+ where+ create x = (Trigger False $ Set.toList x, Hide x)++ inv (ks,x)+ | trigger ks = create $ Set.fromList $ fromTrigger ks+ | otherwise = (ks,x)+++-- | Invariant preserving version of @IntMap@ from the @containers@ packages, suitable for use with 'Uniplate'.+-- Use 'toIntMap' to construct values, and 'fromIntMap' to deconstruct values.+newtype IntMap v = IntMap (Invariant (Trigger [Int], Trigger [v], Hide (IntMap.IntMap v)))+ deriving (Data, Typeable)++instance Show v => Show (IntMap v) where; show = show . fromIntMap+instance Eq v => Eq (IntMap v) where; a == b = fromIntMap a == fromIntMap b+instance Ord v => Ord (IntMap v) where; compare a b = compare (fromIntMap a) (fromIntMap b)++-- | Deconstruct a value of type 'IntMap'.+fromIntMap :: IntMap v -> IntMap.IntMap v+fromIntMap (IntMap (Invariant _ (_,_,Hide x))) = x++-- | Construct a value of type 'IntMap'.+toIntMap :: IntMap.IntMap v -> IntMap v+toIntMap x = IntMap $ Invariant inv $ create x+ where+ create x = (Trigger False ks, Trigger False vs, Hide x)+ where (ks,vs) = unzip $ IntMap.toAscList x++ inv (ks,vs,x)+ | trigger ks = create $ IntMap.fromList $ zip (fromTrigger ks) (fromTrigger vs)+ | trigger vs = create $ IntMap.fromDistinctAscList $ zip (fromTrigger ks) (fromTrigger vs) -- recreate ks/vs to reduce memory usage+ | otherwise = (ks,vs,x)+++-- | Invariant preserving version of @IntSet@ from the @containers@ packages, suitable for use with 'Uniplate'.+-- Use 'toIntSet' to construct values, and 'fromIntSet' to deconstruct values.+newtype IntSet = IntSet (Invariant (Trigger [Int], Hide (IntSet.IntSet)))+ deriving (Data, Typeable)++instance Show IntSet where; show = show . fromIntSet+instance Eq IntSet where; a == b = fromIntSet a == fromIntSet b+instance Ord IntSet where; compare a b = compare (fromIntSet a) (fromIntSet b)++-- | Deconstruct a value of type 'IntSet'.+fromIntSet :: IntSet -> IntSet.IntSet+fromIntSet (IntSet (Invariant _ (_,Hide x))) = x++-- | Construct a value of type 'IntSet'.+toIntSet :: IntSet.IntSet -> IntSet+toIntSet x = IntSet $ Invariant inv $ create x+ where+ create x = (Trigger False $ IntSet.toList x, Hide x)++ inv (ks,x)+ | trigger ks = create $ IntSet.fromList $ fromTrigger ks+ | otherwise = (ks,x)
Data/Generics/Uniplate/DataOnly.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, Rank2Types, CPP, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} {- | This module functions identically to "Data.Generics.Uniplate.Data", but instead of@@ -10,7 +11,8 @@ the same project and they are conflicting. -} module Data.Generics.Uniplate.DataOnly(- module Data.Generics.Uniplate.Internal.DataOnlyOperations+ module Data.Generics.Uniplate.Internal.DataOnlyOperations,+ transformBis, Transformer, transformer ) where import Data.Generics.Uniplate.Internal.DataOnlyOperations
Data/Generics/Uniplate/Direct.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} {- | This module supplies a method for writing 'Uniplate' and 'Biplate' instances. This moulde gives the highest performance, but requires many instance definitions. The instances can be generated using Derive: <http://community.haskell.org/~ndm/derive/>.- + To take an example:- + > data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr > data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr >@@ -31,9 +32,20 @@ > biplate (Seq x ) = plate Seq ||+ x > biplate (Sel x ) = plate Sel ||* x > biplate (Let x y) = plate Let |- x |* y--}- + To define instances for abstract data types, such as @Map@ or @Set@ from the @containers@ package,+ use 'plateProject'.++ This module provides a few monomorphic instances of 'Uniplate' / 'Biplate'+ for common types available in the base library, but does not provide any polymorphic+ instances. Given only monomorphic instances it is trivial to ensure that all instances+ are disjoint, making it easier to add your own instances.++ When defining polymorphic instances, be carefully to mention all potential children.+ Consider @Biplate Int (Int, a)@ - this instance cannot be correct because it will fail+ to return both @Int@ values on @(Int,Int)@. There are some legitimate polymorphic instances,+ such as @Biplate a [a]@ and @Biplate a a@, but take care to avoid overlapping instances.+-} module Data.Generics.Uniplate.Direct( module Data.Generics.Uniplate.Operations, -- * The Combinators@@ -55,27 +67,43 @@ -- The following rule can be used for optimisation: -- -- > plate Ctor |- x == plate (Ctor x)-{-# INLINE plate #-}+{-# INLINE[1] plate #-} plate :: from -> Type from to plate f = (Zero, \_ -> f) +{-# RULES+"plate/-" forall f x. plate f |- x = plate (f x)+"plate/+" forall f x. plate f |+ x = platePlus f x+"plate/*" forall f x. plate f |* x = plateStar f x #-}+++{-# INLINE plateStar #-}+plateStar :: (to -> from) -> to -> Type from to+plateStar f x = (One x, \(One x) -> f x)++{-# INLINE platePlus #-}+platePlus :: Biplate item to => (item -> from) -> item -> Type from to+platePlus f x = case biplate x of+ (ys,y_) -> (ys, \ys -> f $ y_ ys)++ -- | The field to the right is the target.-{-# INLINE (|*) #-}+{-# INLINE[1] (|*) #-} (|*) :: Type (to -> from) to -> to -> Type from to (|*) (xs,x_) y = (Two xs (One y),\(Two xs (One y)) -> x_ xs y) -- | The field to the right may contain the target.-{-# INLINE (|+) #-}+{-# INLINE[1] (|+) #-} (|+) :: Biplate item to => Type (item -> from) to -> item -> Type from to (|+) (xs,x_) y = case biplate y of (ys,y_) -> (Two xs ys, \(Two xs ys) -> x_ xs (y_ ys)) -- | The field to the right /does not/ contain the target.-{-# INLINE (|-) #-}+{-# INLINE[1] (|-) #-} (|-) :: Type (item -> from) to -> item -> Type from to (|-) (xs,x_) y = (xs,\xs -> x_ xs y) @@ -101,11 +129,14 @@ -- | Write an instance in terms of a projection/injection pair. Usually used to define instances -- for abstract containers such as Map: --+-- > instance Biplate (Map.Map [Char] Int) Char where+-- > biplate = plateProject Map.toList Map.fromList+--+-- If the types ensure that no operations will not change the keys+-- we can use the 'fromDistictAscList' function to reconstruct the Map:+-- -- > instance Biplate (Map.Map [Char] Int) Int where -- > biplate = plateProject Map.toAscList Map.fromDistinctAscList------ Because we know that Uniplate operations will not change the keys,--- we can use the 'fromDistictAscList' function to reconstruct it. plateProject :: Biplate item to => (from -> item) -> (item -> from) -> from -> Type from to plateProject into outof = second (outof . ) . biplate . into
Data/Generics/Uniplate/Internal/Data.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-} {- | Internal module, do not import or use.@@ -9,151 +10,59 @@ import Data.Generics.Str import Data.Generics.Uniplate.Internal.Utils import Data.Data+import Data.Generics import Data.Maybe import Data.List-import qualified Data.IntSet as IntSet-import Data.IntSet(IntSet)-import qualified Data.IntMap as IntMap-import Data.IntMap(IntMap) import Data.IORef import Control.Exception-+import Control.Monad+import System.Environment(getEnv)+import qualified Data.IntMap as IntMap; import Data.IntMap(IntMap) ------------------------------------------------------------------------ HIT TEST---data Answer a = Hit {fromHit :: a} -- you just hit the element you were after (here is a cast)- | Follow -- go forward, you will find something- | Miss -- you failed to sink my battleship!--data Oracle to = Oracle {fromOracle :: forall on . Typeable on => on -> Answer to}--{-# INLINE hitTest #-}-hitTest :: (Data from, Data to) => from -> to -> Oracle to---#if __GLASGOW_HASKELL__ < 606--- GHC 6.4.2 does not export typeRepKey, so we can't do the trick--- as efficiently, so we just give up and revert to always following--hitTest _ _ = Oracle . maybe Follow Hit . cast---#elif 0---hitTest from to =- let kto = typeKey to- in case hitTestQuery (dataBox from) kto of- Nothing -> Oracle $ \on -> if typeKey on == kto then Hit $ unsafeCoerce on else Follow- Just cache -> let test = cacheHitTest cache in- Oracle $ \on -> let kon = typeKey on in- if kon == kto then Hit $ unsafeCoerce on- else if test kon then Follow- else Miss----- A cache hit test, but partially evaluated-{-# INLINE cacheHitTest #-}-cacheHitTest :: Cache -> TypeKey -> Bool-cacheHitTest (Cache hit miss)- | IntSet.null hit = const False- | IntSet.null miss = const True- | otherwise = \x -> x `IntSet.member` hit----- hit means that this value may result in a hit--- miss means that this value will never result in a hit-data Cache = Cache {hit :: IntSet, miss :: IntSet} deriving Show-newCache = Cache IntSet.empty IntSet.empty----- Indexed by the @from@ type, then the @to@ type--- Nothing means that we can't perform the trick on the set-{-# NOINLINE hitTestCache #-}-hitTestCache :: IORef (IntMap (IntMap (Maybe Cache)))-hitTestCache = unsafePerformIO $ newIORef IntMap.empty-+-- GHC 7.2 and above (using fingerprint) -hitTestQuery :: DataBox -> TypeKey -> Maybe Cache-hitTestQuery from@(DataBox kfrom vfrom) kto = inlinePerformIO $ do- mp <- readIORef hitTestCache- let res = IntMap.lookup kfrom mp >>= IntMap.lookup kto- case res of- Just ans -> return ans- Nothing -> do- let res = toCache $ hitTestAdd from kto IntMap.empty- res2 <- Control.Exception.catch (return $! res) (\(_ :: SomeException) -> return Nothing)- -- -- uncomment these lines to see where type search fails- -- if isNothing res2 then print ("failure",show (typeOf vfrom),kfrom,kto) else return ()+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+type TypeSet = Set.HashSet TypeKey+type TypeMap = Map.HashMap TypeKey - atomicModifyIORef hitTestCache $ \mp -> flip (,) () $- IntMap.insertWith (const $ IntMap.insert kto res2) kfrom (IntMap.singleton kto res2) mp- return res2+type TypeKey = TypeRep +typeKey :: Typeable a => a -> TypeKey+typeKey = typeOf --- need to classify each item as one of the following-data Res = RHit | RMiss | RFollow | RBad deriving (Show,Eq)+(!) mp k = map_findWithDefault (error "Could not find element") k mp+map_findWithDefault d k mp = fromMaybe d $ Map.lookup k mp -- in 0.2.3.0 lookupDefault is strict in the default :(+map_fromAscList = Map.fromList+map_keysSet = Set.fromList . Map.keys+map_member x xs = isJust $ Map.lookup x xs+set_partition f x = (Set.filter f x, Set.filter (not . f) x)+set_toAscList = Set.toList+set_unions = foldr Set.union Set.empty -toCache :: IntMap Res -> Maybe Cache-toCache res | not $ IntSet.null $ f RBad = Nothing- | otherwise = Just $ Cache (f RFollow) (f RMiss)- where f x = IntMap.keysSet $ IntMap.filter (== x) res--hitTestAdd :: DataBox -> TypeKey -> IntMap Res -> IntMap Res-hitTestAdd from@(DataBox kfrom _) kto res = case sybChildren from of- _ | kfrom `IntMap.member` res -> res- Nothing -> IntMap.insert kfrom RBad res-- -- make an inductive hypothesis that this value is a miss- -- if it turns out you were wrong, start again- -- uses backtracking, so could be expensive- Just xs | kto == kfrom -> hitTestAdds xs kto $ IntMap.insert kfrom RHit res- | correct -> res2- | otherwise -> hitTestAdds xs kto $ IntMap.insert kfrom RFollow res- where res2 = hitTestAdds xs kto $ IntMap.insert kfrom RMiss res- correct = all ((==) RMiss . (res2 IntMap.!) . dataBoxKey) xs--hitTestAdds :: [DataBox] -> TypeKey -> IntMap Res -> IntMap Res-hitTestAdds [] kto res = res-hitTestAdds (x:xs) kto res = hitTestAdds xs kto $ hitTestAdd x kto res+{-# NOINLINE uniplateVerbose #-}+uniplateVerbose :: Int -- -1 = error if failed, 0 = quiet, 1 = print errors only, 2 = print everything+uniplateVerbose = unsafePerformIO $ do+ fmap read (getEnv "UNIPLATE_VERBOSE") `Control.Exception.catch` \(_ :: SomeException) -> return 0 -type TypeKey = Int--typeKey :: Typeable a => a -> Int-typeKey x = inlinePerformIO $ typeRepKey $ typeOf x+---------------------------------------------------------------------+-- HIT TEST --- | An existential box representing a type which supports SYB--- operations.-data DataBox = forall a . (Data a) => DataBox {dataBoxKey :: TypeKey, dataBoxVal :: a}--dataBox :: Data a => a -> DataBox-dataBox x = DataBox (typeKey x) x---- return all the possible children of a node--- if you can't do so, just return Nothing-sybChildren :: DataBox -> Maybe [DataBox]-sybChildren (DataBox k x)- | k == typeRational = Just [dataBox (0 :: Integer)]- | isAlgType dtyp = Just $ concatMap f ctrs- | isNorepType dtyp = Nothing- | otherwise = Just []- where- f ctr = gmapQ dataBox (asTypeOf (fromConstr ctr) x)- ctrs = dataTypeConstrs dtyp- dtyp = dataTypeOf x--typeRational = typeKey (undefined :: Rational)+data Answer a = Hit {fromHit :: a} -- you just hit the element you were after (here is a cast)+ | Follow -- go forward, you will find something+ | Miss -- you failed to sink my battleship! -#else+data Oracle to = Oracle {fromOracle :: forall on . Typeable on => on -> Answer to} +{-# INLINE hitTest #-}+hitTest :: (Data from, Data to) => from -> to -> Oracle to hitTest from to = let kto = typeKey to- in case readCache (dataBox from) kto of+ in case readCacheFollower (dataBox from) kto of Nothing -> Oracle $ \on -> if typeKey on == kto then Hit $ unsafeCoerce on else Follow Just test -> Oracle $ \on -> let kon = typeKey on in if kon == kto then Hit $ unsafeCoerce on@@ -166,42 +75,71 @@ -- CACHE -- Store and compute the Follower and HitMap -data Cache = Cache HitMap (IntMap2 (Maybe Follower))+data Cache = Cache HitMap (TypeMap2 (Maybe Follower)) -- Indexed by the @from@ type, then the @to@ type -- Nothing means that we can't perform the trick on the set {-# NOINLINE cache #-} cache :: IORef Cache-cache = unsafePerformIO $ newIORef $ Cache emptyHitMap IntMap.empty+cache = unsafePerformIO $ newIORef $ Cache emptyHitMap Map.empty -readCache :: DataBox -> TypeKey -> Maybe Follower-readCache from@(DataBox kfrom vfrom) kto = inlinePerformIO $ do+readCacheFollower :: DataBox -> TypeKey -> Maybe Follower+readCacheFollower from@(DataBox kfrom vfrom) kto = inlinePerformIO $ do Cache hit follow <- readIORef cache case lookup2 kfrom kto follow of Just ans -> return ans Nothing -> do- res <- Control.Exception.catch (return $! Just $! insertHitMap from hit) (\(_ :: SomeException) -> return Nothing)+ res <- Control.Exception.try (return $! insertHitMap from hit) (hit,fol) <- return $ case res of- Nothing -> (hit, Nothing)- Just hit -> (hit, Just $ follower kfrom kto hit)- -- -- uncomment these lines to see where type search fails- -- if isNothing fol then print ("failure",show (typeOf vfrom),kfrom,kto) else return ()+ Left _ -> (hit, Nothing)+ Right hit -> (hit, Just $ follower kfrom kto hit) + let msg =+ "# Uniplate lookup on (" ++ show (typeOf vfrom) ++ "), from (" ++ show kfrom ++ "), to (" ++ show kto ++ "): " +++ either (\(msg::SomeException) -> "FAILURE (" ++ show msg ++ ")") (const "Success") res++ when (uniplateVerbose + maybe 1 (const 0) fol >= 2) $ putStrLn msg+ when (uniplateVerbose < 0 && isNothing fol) $ error msg+ atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hit (insert2 kfrom kto fol follow), ()) return fol +-- from which values, what can you reach+readCacheHitMap :: DataBox -> Maybe HitMap+readCacheHitMap from@(DataBox kfrom vfrom) = inlinePerformIO $ do+ Cache hit _ <- readIORef cache+ case Map.lookup kfrom hit of+ Just _ -> return $ Just hit+ Nothing -> do+ res <- Control.Exception.catch (return $! Just $! insertHitMap from hit) (\(_ :: SomeException) -> return Nothing)+ case res of+ Nothing -> return Nothing+ Just hit -> do+ atomicModifyIORef cache $ \(Cache _ follow) -> (Cache hit follow, ())+ return $ Just hit++ ------------------------------------------------------------------------ INTMAP2+-- TYPEMAP2/INTMAP2 +type TypeMap2 a = TypeMap (TypeMap a)++lookup2 :: TypeKey -> TypeKey -> TypeMap2 a -> Maybe a+lookup2 x y mp = Map.lookup x mp >>= Map.lookup y++insert2 :: TypeKey -> TypeKey -> a -> TypeMap2 a -> TypeMap2 a+insert2 x y v mp = Map.insertWith (const $ Map.insert y v) x (Map.singleton y v) mp++ type IntMap2 a = IntMap (IntMap a) -lookup2 :: Int -> Int -> IntMap (IntMap x) -> Maybe x-lookup2 x y mp = IntMap.lookup x mp >>= IntMap.lookup y+intLookup2 :: Int -> Int -> IntMap2 a -> Maybe a+intLookup2 x y mp = IntMap.lookup x mp >>= IntMap.lookup y -insert2 :: Int -> Int -> x -> IntMap (IntMap x) -> IntMap (IntMap x)-insert2 x y v mp = IntMap.insertWith (const $ IntMap.insert y v) x (IntMap.singleton y v) mp+intInsert2 :: Int -> Int -> a -> IntMap2 a -> IntMap2 a+intInsert2 x y v mp = IntMap.insertWith (const $ IntMap.insert y v) x (IntMap.singleton y v) mp ---------------------------------------------------------------------@@ -214,23 +152,18 @@ -- HitMap must have addHitMap on the key follower :: TypeKey -> TypeKey -> HitMap -> Follower follower from to mp- | IntSet.null hit = const False- | IntSet.null miss = const True- | otherwise = \now -> now `IntSet.member` hit+ | Set.null hit = const False+ | Set.null miss = const True+ | Set.size hit < Set.size miss = \k -> k `Set.member` hit+ | otherwise = \k -> not $ k `Set.member` miss where- (hit,miss) = IntSet.partition (\x -> to `IntSet.member` grab x) (IntSet.insert from $ grab from)- grab x = IntMap.findWithDefault (error "couldn't grab in follower") x mp+ (hit,miss) = set_partition (\x -> to `Set.member` grab x) (Set.insert from $ grab from)+ grab x = map_findWithDefault (error "couldn't grab in follower") x mp --------------------------------------------------------------------- -- DATA/TYPEABLE OPERATIONS -type TypeKey = Int--typeKey :: Typeable a => a -> Int-typeKey x = inlinePerformIO $ typeRepKey $ typeOf x-- -- | An existential box representing a type which supports SYB -- operations. data DataBox = forall a . (Data a) => DataBox {dataBoxKey :: TypeKey, dataBoxVal :: a}@@ -243,7 +176,11 @@ sybChildren :: Data a => a -> [DataBox] sybChildren x | isAlgType dtyp = concatMap f ctrs- | isNorepType dtyp = error "sybChildren on NorepType"+ | isNorepType dtyp = []+ -- Extensive discussions with Lennart and Roman decided that if something returns NorepType, it really wants to be atomic+ -- so we should let it be, and pretend it has no children.+ -- The most common types which say this are Data.Set/Data.Map, and we think that's a bug in their Data instances.+ -- error $ "Data.Generics.Uniplate.Data: sybChildren on data type which returns NorepType, " ++ show (typeOf x) ++ ", " ++ show dtyp | otherwise = [] where f ctr = gmapQ dataBox (asTypeOf (fromConstr ctr) x)@@ -255,26 +192,26 @@ -- HITMAP -- What is the transitive closure of a type key -type HitMap = IntMap IntSet+type HitMap = TypeMap TypeSet emptyHitMap :: HitMap-emptyHitMap = IntMap.fromList- [(tRational, IntSet.singleton tInteger)- ,(tInteger, IntSet.empty)]+emptyHitMap = Map.fromList+ [(tRational, Set.singleton tInteger)+ ,(tInteger, Set.empty)] where tRational = typeKey (undefined :: Rational) tInteger = typeKey (0 :: Integer) insertHitMap :: DataBox -> HitMap -> HitMap-insertHitMap box hit = fixEq trans (populate box) `IntMap.union` hit+insertHitMap box hit = fixEq trans (populate box) `Map.union` hit where -- create a fresh box with all the necessary children that aren't in hit populate :: DataBox -> HitMap- populate x = f x IntMap.empty+ populate x = f x Map.empty where f (DataBox key val) mp- | key `IntMap.member` hit || key `IntMap.member` mp = mp- | otherwise = fs cs $ IntMap.insert key (IntSet.fromList $ map dataBoxKey cs) mp+ | key `map_member` hit || key `map_member` mp = mp+ | otherwise = fs cs $ Map.insert key (Set.fromList $ map dataBoxKey cs) mp where cs = sybChildren val fs [] mp = mp@@ -283,10 +220,10 @@ -- update every one to be the transitive closure trans :: HitMap -> HitMap- trans mp = IntMap.map f mp+ trans mp = Map.map f mp where- f x = IntSet.unions $ x : map g (IntSet.toList x)- g x = IntMap.findWithDefault (hit IntMap.! x) x mp+ f x = set_unions $ x : map g (Set.toList x)+ g x = map_findWithDefault (hit ! x) x mp fixEq :: Eq a => (a -> a) -> a -> a@@ -294,8 +231,8 @@ where x2 = f x -#endif-+---------------------------------------------------------------------+-- INSTANCE FUNCTIONS newtype C x a = C {fromC :: CC x a} @@ -328,3 +265,99 @@ Hit y -> unsafeCoerce $ op y Follow -> gmapT (descendBiData oracle op) x Miss -> x++descendDataM :: (Data on, Applicative m) => (forall a . Typeable a => a -> Answer on) -> (on -> m on) -> on -> m on+descendDataM oracle op = gmapA (descendBiDataM oracle op)++descendBiDataM :: (Data on, Data with, Applicative m) => (forall a . Typeable a => a -> Answer with) -> (with -> m with) -> on -> m on+descendBiDataM oracle op x = case oracle x of+ Hit y -> unsafeCoerce $ op y+ Follow -> gmapA (descendBiDataM oracle op) x+ Miss -> pure x++gmapA :: forall m a. (Data a, Applicative m) => (forall d. Data d => d -> m d) -> a -> m a+gmapA f = gfoldl k pure+ where k :: Data d => m (d -> b) -> d -> m b+ k c x = c <*> f x+++---------------------------------------------------------------------+-- FUSION++data Transformer = forall a . Data a => Transformer TypeKey (a -> a)+++-- | Wrap up a @(a -> a)@ transformation function, to use with 'transformBis'+transformer :: Data a => (a -> a) -> Transformer+transformer = transformer_+++-- Don't export directly, as don't want Haddock to see the forall+transformer_ :: forall a . Data a => (a -> a) -> Transformer+transformer_ = Transformer (typeKey (undefined :: a))+++-- | Apply a sequence of transformations in order. This function obeys the equivalence:+--+-- > transformBis [[transformer f],[transformer g],...] == transformBi f . transformBi g . ...+--+-- Each item of type @[Transformer]@ is applied in turn, right to left. Within each+-- @[Transformer]@, the individual @Transformer@ values may be interleaved.+--+-- The implementation will attempt to perform fusion, and avoid walking any part of the+-- data structure more than necessary. To further improve performance, you may wish to+-- partially apply the first argument, which will calculate information about the relationship+-- between the transformations.+transformBis :: forall a . Data a => [[Transformer]] -> a -> a+transformBis = transformBis_+++transformBis_ :: forall a . Data a => [[Transformer]] -> a -> a++-- basic algorithm:+-- as you go down, given transformBis [fN..f1]+-- if x is not in the set reachable by fN..f1, return x+-- if x is in the reachable set, gmap (transformBis [fN..f1]) x+-- if x is one of fN..f1, pick the lowest fi then+-- transformBis [fN..f(i+1)] $ fi $ gmap (transformBis [fi..f1]) x++transformBis_ ts | isJust hitBoxM = op (sliceMe 1 n)+ where+ on = dataBox (undefined :: a)+ hitBoxM = readCacheHitMap on+ hitBox = fromJust hitBoxM+ univ = set_toAscList $ Set.insert (dataBoxKey on) $ hitBox ! dataBoxKey on+ n = length ts++ -- (a,b), where a < b, and both in range 1..n+ sliceMe i j = fromMaybe Map.empty $ intLookup2 i j slices+ slices :: IntMap2 (TypeMap (Maybe Transformer))+ slices = IntMap.fromAscList+ [ (i, IntMap.fromAscList [(j, slice i j ts) | (j,ts) <- zip [i..n] (tail $ inits ts)])+ | (i,ts) <- zip [1..n] (tails $ reverse ts)]++ slice :: Int -> Int -> [[Transformer]] -> TypeMap (Maybe Transformer)+ slice from to tts = self+ where+ self = f Map.empty (zip [from..] tts) -- FIXME: flattening out here gives different results...+ f a ((i,[Transformer tk tr]):ts)+ | tk `map_member` a = f a ts+ | otherwise = f (Map.insert tk t a) ts+ where+ t = Just $ Transformer tk $ op (sliceMe (i+1) to) . tr . gmapT (op $ sliceMe from i)++ f a [] = a `Map.union` map_fromAscList (mapMaybe (g $ map_keysSet a) univ)++ g a t = if b then Nothing else Just (t, Nothing)+ where b = Set.null $ a `Set.intersection` (hitBox ! t)++ op :: forall b . Data b => TypeMap (Maybe Transformer) -> b -> b+ op slice = case Map.lookup (typeKey (undefined :: b)) slice of+ Nothing -> id+ Just Nothing -> gmapT (op slice)+ Just (Just (Transformer _ t)) -> unsafeCoerce . t . unsafeCoerce+++transformBis_ [] = id+transformBis_ ([]:xs) = transformBis_ xs+transformBis_ ((Transformer _ t:x):xs) = everywhere (mkT t) . transformBis_ (x:xs)
Data/Generics/Uniplate/Internal/DataInc.hs view
@@ -8,6 +8,9 @@ descend = descendData $ fromOracle answer where answer = hitTest (undefined :: a) (undefined :: a) + descendM = descendDataM $ fromOracle answer+ where answer = hitTest (undefined :: a) (undefined :: a)+ instance (Data a, Data b, Uniplate b) => Biplate a b where biplate = biplateData $ fromOracle answer where answer = hitTest (undefined :: a) (undefined :: b)@@ -15,3 +18,5 @@ descendBi = descendBiData $ fromOracle answer where answer = hitTest (undefined :: a) (undefined :: b) + descendBiM = descendBiDataM $ fromOracle answer+ where answer = hitTest (undefined :: a) (undefined :: b)
Data/Generics/Uniplate/Internal/OperationsInc.hs view
@@ -1,13 +1,11 @@-import Control.Monad(liftM)-import Data.Traversable-import Prelude hiding (mapM) import Data.Generics.Str import Data.Generics.Uniplate.Internal.Utils -- * The Classes --- | The standard Uniplate class, all operations require this.+-- | The standard Uniplate class, all operations require this. All definitions must+-- define 'uniplate', while 'descend' and 'descendM' are optional. class Uniplate on where -- | The underlying method in the class. -- Taking a value, the function should return all the immediate children@@ -30,35 +28,52 @@ -- | Perform a transformation on all the immediate children, then combine them back. -- This operation allows additional information to be passed downwards, and can be- -- used to provide a top-down transformation.+ -- used to provide a top-down transformation. This function can be defined explicitly,+ -- or can be provided by automatically in terms of 'uniplate'.+ --+ -- For example, on the sample type, we could write:+ --+ -- > descend f (Val i ) = Val i+ -- > descend f (Neg a ) = Neg (f a)+ -- > descend f (Add a b) = Add (f a) (f b)+ {-# INLINE descend #-} descend :: (on -> on) -> on -> on- descend f x = generate $ fmap f current- where (current, generate) = uniplate x+ descend f x = case uniplate x of+ (current, generate) -> generate $ strMap f current - -- | Monadic variant of 'descend' - descendM :: Monad m => (on -> m on) -> on -> m on- descendM f x = liftM generate $ mapM f current- where (current, generate) = uniplate x+ -- | Applicative variant of 'descend'+ {-# INLINE descendM #-}+ descendM :: Applicative m => (on -> m on) -> on -> m on+ descendM f x = case uniplate x of+ (current, generate) -> generate <$> strMapM f current + -- | Children are defined as the top-most items of type to--- /starting at the root/.+-- /starting at the root/. All instances must define 'biplate', while+-- 'descendBi' and 'descendBiM' are optional. class Uniplate to => Biplate from to where -- | Return all the top most children of type @to@ within @from@. --- -- If @from == to@ then this function should return the root as the single- -- child.+ -- If @from == to@ then this function should return the root as the single+ -- child. biplate :: from -> (Str to, Str to -> from) + -- | Like 'descend' but with more general types. If @from == to@ then this+ -- function /does not/ descend. Therefore, when writing definitions it is+ -- highly unlikely that this function should be used in the recursive case.+ -- A common pattern is to first match the types using 'descendBi', then continue+ -- the recursion with 'descend'.+ {-# INLINE descendBi #-} descendBi :: (to -> to) -> from -> from- descendBi f x = generate $ fmap f current- where (current, generate) = biplate x-+ descendBi f x = case biplate x of+ (current, generate) -> generate $ strMap f current - descendBiM :: Monad m => (to -> m to) -> from -> m from- descendBiM f x = liftM generate $ mapM f current- where (current, generate) = biplate x+ {-# INLINE descendBiM #-}+ descendBiM :: Applicative m => (to -> m to) -> from -> m from+ descendBiM f x = case biplate x of+ (current, generate) -> generate <$> strMapM f current -- * Single Type Operations@@ -109,8 +124,8 @@ where g = f . descend g --- | Monadic variant of 'transform'-transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on+-- | Applicative variant of 'transform'+transformM :: (Monad m, Applicative m, Uniplate on) => (on -> m on) -> on -> m on transformM f = g where g x = f =<< descendM g x @@ -127,8 +142,8 @@ where g x = maybe x (rewrite f) (f x) --- | Monadic variant of 'rewrite'-rewriteM :: (Monad m, Uniplate on) => (on -> m (Maybe on)) -> on -> m on+-- | Applicative variant of 'rewrite'+rewriteM :: (Monad m, Applicative m, Uniplate on) => (on -> m (Maybe on)) -> on -> m on rewriteM f = transformM g where g x = f x >>= maybe (return x) (rewriteM f) @@ -137,8 +152,8 @@ -- | Return all the contexts and holes. ----- > propUniverse x = universe x == map fst (contexts x)--- > propId x = all (== x) [b a | (a,b) <- contexts x]+-- > universe x == map fst (contexts x)+-- > all (== x) [b a | (a,b) <- contexts x] contexts :: Uniplate on => on -> [(on, on -> on)] contexts x = (x,id) : f (holes x) where@@ -149,8 +164,8 @@ -- | The one depth version of 'contexts' ----- > propChildren x = children x == map fst (holes x)--- > propId x = all (== x) [b a | (a,b) <- holes x]+-- > children x == map fst (holes x)+-- > all (== x) [b a | (a,b) <- holes x] holes :: Uniplate on => on -> [(on, on -> on)] holes x = uncurry f (uniplate x) where f Zero _ = []@@ -194,24 +209,20 @@ {-# INLINE transformBi #-} transformBi :: Biplate from to => (to -> to) -> from -> from-transformBi f x = generate $ fmap (transform f) current- where (current, generate) = biplate x+transformBi f = descendBi (transform f) {-# INLINE transformBiM #-}-transformBiM :: (Monad m, Biplate from to) => (to -> m to) -> from -> m from-transformBiM f x = liftM generate $ mapM (transformM f) current- where (current, generate) = biplate x+transformBiM :: (Monad m, Applicative m, Biplate from to) => (to -> m to) -> from -> m from+transformBiM f = descendBiM (transformM f) rewriteBi :: Biplate from to => (to -> Maybe to) -> from -> from-rewriteBi f x = generate $ fmap (rewrite f) current- where (current, generate) = biplate x+rewriteBi f = descendBi (rewrite f) -rewriteBiM :: (Monad m, Biplate from to) => (to -> m (Maybe to)) -> from -> m from-rewriteBiM f x = liftM generate $ mapM (rewriteM f) current- where (current, generate) = biplate x+rewriteBiM :: (Monad m, Applicative m, Biplate from to) => (to -> m (Maybe to)) -> from -> m from+rewriteBiM f = descendBiM (rewriteM f) -- ** Others
Data/Generics/Uniplate/Internal/Utils.hs view
@@ -1,41 +1,29 @@-{-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification #-}--{- |- Internal module, do not import or use.--}+{-# LANGUAGE Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- SPEC2 +-- | Internal module, do not import or use. module Data.Generics.Uniplate.Internal.Utils(- unsafeCoerce, builder, unsafePerformIO, inlinePerformIO, concatCont+ unsafeCoerce, builder, unsafePerformIO, inlinePerformIO, concatCont, SPEC(SPEC) ) where -import Foreign(unsafePerformIO)+import System.IO.Unsafe(unsafePerformIO) import Unsafe.Coerce(unsafeCoerce) -#ifdef __GLASGOW_HASKELL__ import GHC.Exts(build, realWorld#)-import GHC.IOBase(IO(IO))-#endif+import GHC.IO(IO(IO))+import GHC.Types(SPEC(..)) {-# INLINE builder #-} -- | GHCs @foldr@\/@build@ system, but on all platforms-#ifdef __GLASGOW_HASKELL__ builder :: forall a . (forall b . (a -> b -> b) -> b -> b) -> [a] builder = build-#else-builder :: ((x -> [x] -> [x]) -> [x] -> [x]) -> [x]-builder f = f (:) []-#endif {-# INLINE inlinePerformIO #-} -- | 'unsafePerformIO', but suitable for inlining. Copied from "Data.ByteString.Base". inlinePerformIO :: IO a -> a-#ifdef __GLASGOW_HASKELL__ inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-#else-inlinePerformIO = unsafePerformIO-#endif {-# INLINE concatCont #-}
Data/Generics/Uniplate/Typeable.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} {- | /RECOMMENDATION:/ Use "Data.Generics.Uniplate.Data" instead - it usually performs
+ Data/Generics/Uniplate/Zipper.hs view
@@ -0,0 +1,157 @@+{-|+A zipper is a structure for walking a value and manipulating it in constant time.++This module was inspired by the paper:+/Michael D. Adams. Scrap Your Zippers: A Generic Zipper for Heterogeneous Types, Workshop on Generic Programming 2010/.+-}+++module Data.Generics.Uniplate.Zipper(+ -- * Create a zipper and get back the value+ Zipper, zipper, zipperBi, fromZipper,+ -- * Navigate within a zipper+ left, right, up, down,+ -- * Manipulate the zipper hole+ hole, replaceHole+ ) where++import Data.Generics.Uniplate.Operations+import Data.Generics.Str+import Control.Monad+import Data.Maybe+++-- | Create a zipper, focused on the top-left value.+zipper :: Uniplate to => to -> Zipper to to+zipper = fromJust . toZipper (\x -> (One x, \(One x) -> x))+++-- | Create a zipper with a different focus type from the outer type. Will return+-- @Nothing@ if there are no instances of the focus type within the original value.+zipperBi :: Biplate from to => from -> Maybe (Zipper from to)+zipperBi = toZipper biplate+++-- | Zipper structure, whose root type is the first type argument, and whose+-- focus type is the second type argument.+data Zipper from to = Zipper+ {reform :: Str to -> from+ ,zipp :: ZipN to+ }++rezipp f (Zipper a b) = fmap (Zipper a) $ f b++instance (Eq from, Eq to) => Eq (Zipper from to) where+ a == b = fromZipper a == fromZipper b && zipp a == zipp b+++toZipper :: Uniplate to => (from -> (Str to, Str to -> from)) -> from -> Maybe (Zipper from to)+toZipper biplate x = fmap (Zipper gen) $ zipN cs+ where (cs,gen) = biplate x+++-- | From a zipper take the whole structure, including any modifications.+fromZipper :: Zipper from to -> from+fromZipper x = reform x $ top1 $ topN $ zipp x+++-- | Move one step left from the current position.+left :: Zipper from to -> Maybe (Zipper from to)+left = rezipp leftN++-- | Move one step right from the current position.+right :: Zipper from to -> Maybe (Zipper from to)+right = rezipp rightN++-- | Move one step down from the current position.+down :: Uniplate to => Zipper from to -> Maybe (Zipper from to)+down = rezipp downN++-- | Move one step up from the current position.+up :: Zipper from to -> Maybe (Zipper from to)+up = rezipp upN+++-- | Retrieve the current focus of the zipper..+hole :: Zipper from to -> to+hole = holeN . zipp+++-- | Replace the value currently at the focus of the zipper.+replaceHole :: to -> Zipper from to -> Zipper from to+replaceHole x z = z{zipp=replaceN x (zipp z)}+++---------------------------------------------------------------------+-- N LEVEL ZIPPER ON Str++data ZipN x = ZipN [Str x -> Zip1 x] (Zip1 x)++instance Eq x => Eq (ZipN x) where+ x@(ZipN _ xx) == y@(ZipN _ yy) = xx == yy && upN x == upN y++zipN :: Str x -> Maybe (ZipN x)+zipN x = fmap (ZipN []) $ zip1 x++leftN (ZipN p x) = fmap (ZipN p) $ left1 x+rightN (ZipN p x) = fmap (ZipN p) $ right1 x+holeN (ZipN _ x) = hole1 x+replaceN v (ZipN p x) = ZipN p $ replace1 x v++upN (ZipN [] x) = Nothing+upN (ZipN (p:ps) x) = Just $ ZipN ps $ p $ top1 x++topN (ZipN [] x) = x+topN x = topN $ fromJust $ upN x++downN :: Uniplate x => ZipN x -> Maybe (ZipN x)+downN (ZipN ps x) = fmap (ZipN $ replace1 x . gen : ps) $ zip1 cs+ where (cs,gen) = uniplate $ hole1 x+++---------------------------------------------------------------------+-- 1 LEVEL ZIPPER ON Str++data Diff1 a = TwoLeft (Str a) | TwoRight (Str a) deriving Eq++undiff1 r (TwoLeft l) = Two l r+undiff1 l (TwoRight r) = Two l r++-- Warning: this definition of Eq may look too strong (Str Left/Right is not relevant)+-- but you don't know what the uniplate.gen function will do+data Zip1 a = Zip1 [Diff1 a] a deriving Eq++zip1 :: Str x -> Maybe (Zip1 x)+zip1 = insert1 True []++insert1 :: Bool -> [Diff1 a] -> Str a -> Maybe (Zip1 a)+insert1 leftmost c Zero = Nothing+insert1 leftmost c (One x) = Just $ Zip1 c x+insert1 leftmost c (Two l r) = if leftmost then ll `mplus` rr else rr `mplus` ll+ where ll = insert1 leftmost (TwoRight r:c) l+ rr = insert1 leftmost (TwoLeft l:c) r++left1, right1 :: Zip1 a -> Maybe (Zip1 a)+left1 = move1 True+right1 = move1 False++move1 :: Bool -> Zip1 a -> Maybe (Zip1 a)+move1 leftward (Zip1 p x) = f p $ One x+ where+ f p x = msum $+ [insert1 False (TwoRight x:ps) l | TwoLeft l:ps <- [p], leftward] +++ [insert1 True (TwoLeft x:ps) r | TwoRight r:ps <- [p], not leftward] +++ [f ps (x `undiff1` p) | p:ps <- [p]]++top1 :: Zip1 a -> Str a+top1 (Zip1 p x) = f p (One x)+ where f :: [Diff1 a] -> Str a -> Str a+ f [] x = x+ f (p:ps) x = f ps (x `undiff1` p)++hole1 :: Zip1 a -> a+hole1 (Zip1 _ x) = x++-- this way round so the a can be disguarded quickly+replace1 :: Zip1 a -> a -> Zip1 a+replace1 (Zip1 p _) = Zip1 p
Data/Generics/UniplateOn.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} {- |-/RECOMMENDATION/: Use "Data.Generics.Uniplate.Operations" instead.+/DEPRECATED/: Use "Data.Generics.Uniplate.Operations" instead. This module retained Haskell 98 compatability, but users who are happy with multi-parameter type classes should look towards "Data.Generics.Biplate".@@ -13,7 +13,7 @@ -} module Data.Generics.UniplateOn- {- DEPRECATED "Use Data.Generics.UniplateStrOn instead" -}+ {- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -} ( module Data.Generics.Uniplate, module Data.Generics.UniplateOn@@ -21,7 +21,6 @@ import Data.Generics.Uniplate import Control.Monad(liftM)-import Data.List(inits,tails) -- * Types @@ -108,4 +107,3 @@ where (a , b ) = f x (as, bs) = uniplateOnList f xs-
Data/Generics/UniplateStr.hs view
@@ -1,5 +1,5 @@ {- |-/RECOMMENDATION/: Use "Data.Generics.Uniplate.Operations" instead.+/DEPRECATED/: Use "Data.Generics.Uniplate.Operations" instead. This is the main Uniplate module, which defines all the essential operations in a Haskell 98 compatible manner.@@ -13,18 +13,18 @@ -} -module Data.Generics.UniplateStr(+module Data.Generics.UniplateStr+ {- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -}+ ( module Data.Generics.UniplateStr, module Data.Generics.Str ) where import Control.Monad hiding (mapM)-import Data.List(inits,tails)-import Control.Monad.State hiding (mapM) import Data.Traversable import Prelude hiding (mapM) -import Data.Generics.PlateInternal+import Data.Generics.Uniplate.Internal.Utils import Data.Generics.Str @@ -144,7 +144,7 @@ where (current, generate) = uniplate x --- | Monadic variant of 'descend' +-- | Monadic variant of 'descend' descendM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on descendM f x = liftM generate $ mapM f current where (current, generate) = uniplate x
Data/Generics/UniplateStrOn.hs view
@@ -1,5 +1,5 @@ {- |-/RECOMMENDATION/: Use "Data.Generics.Uniplate.Operations" instead.+/DEPRECATED/: Use "Data.Generics.Uniplate.Operations" instead. This module retained Haskell 98 compatability, but users who are happy with multi-parameter type classes should look towards "Data.Generics.Biplate".@@ -11,17 +11,18 @@ identically to their non @On@ counterparts. -} -module Data.Generics.UniplateStrOn(+module Data.Generics.UniplateStrOn+ {- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -}+ ( module Data.Generics.UniplateStr, module Data.Generics.UniplateStrOn ) where import Control.Monad(liftM)-import Data.List(inits,tails) import Data.Traversable import Prelude hiding (mapM) -import Data.Generics.PlateInternal+import Data.Generics.Uniplate.Internal.Utils import Data.Generics.Str import Data.Generics.UniplateStr
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2007.+Copyright Neil Mitchell 2006-2020. All rights reserved. Redistribution and use in source and binary forms, with or without
+ README.md view
@@ -0,0 +1,236 @@+# Boilerplate Removal with Uniplate [](https://hackage.haskell.org/package/uniplate) [](https://www.stackage.org/package/uniplate) [](https://travis-ci.org/ndmitchell/uniplate)++Generic transformations and queries are often referred to as boilerplate code - they remain relatively similar as the action performed by the code changes, and can often outnumber the actual intent of the code in terms of lines. While other generic traversal schemes have shown how powerful new features can be added to compilers, and how the type system can be manipulated into accepting these operations, the Uniplate library focuses on a conceptually simpler generic concept. A more complete document on Uniplate was published at the Haskell Workshop 2007, and is available from [here](https://ndmitchell.com/#uniplate_30_sep_2007), along with a video presentation, and the associated thesis chapter.++Uniplate is a simple, concise and fast generics library. To expand on that sentence:++1. A generics library is one which allows you to write functions that operate over a data structure without tying down all aspects of the data structure. In particular, when writing an operation, you don't need to give a case for each constructor, and you don't have to state which fields are recursive.+2. Uniplate is the simplest generics library. Using Uniplate is within the reach of all Haskell programmers.+3. Uniplate is more concise than any other generics library.+4. Uniplate is fast, not always the absolute fastest, but massively faster than many generics libraries.+5. Uniplate is also less powerful than some other generics libraries, but if it does the job, you should use it.++The Uniplate library can be installed with the standard sequence of cabal commands:++ cabal update+ cabal install uniplate++This document proceeds as follows:++1. Using Uniplate+2. Using Biplate+3. Making Uniplate Faster++#### Acknowledgements++Thanks to Björn Bringert for feedback on an earlier version of this document, Eric Mertens for various ideas and code snippets, and to Matt Naylor and Tom Shackell for helpful discussions.++## Using Uniplate++To demonstrate the facilities of Uniplate, we use a simple arithmetic type:++<pre>+<b>{-# LANGUAGE DeriveDataTypeable #-}</b>+module Expr where+<b>import Data.Data</b>+<b>import Data.Generics.Uniplate.Data</b>++data Expr = Val Int+ | Add Expr Expr+ | Sub Expr Expr+ | Div Expr Expr+ | Mul Expr Expr+ | Neg Expr+ deriving (Show, Eq, <b>Data, Typeable</b>)+</pre>++In this definition, the Uniplate specific bits are bolded. The three extra parts are:++* `import Data.Generics.Uniplate.Data`, this module contains all the Uniplate functions and definitions.+* `deriving (Data,Typeable)`, this deriving clause automatically adds the necessary instances for Uniplate.+* `{-# LANGUAGE DeriveDataTypeable #-}`, this pragma turns on language support for the deriving line.++This definition makes use of the [Scrap Your Boilerplate (SYB)](http://doi.acm.org/10.1145/604174.604179) based Uniplate implementation. The SYB implementation is compatible with the other implementations, but is slower (between 2 and 8 times) and requires some modest compiler extensions (implemented in [GHC](http://haskell.org/ghc/) for many years). The alternative definition scheme is described towards the end of this document, in "Making Uniplate Faster". I recommend using the SYB implementation to start with, as it requires least work to use.++The Uniplate library defines two classes, `Uniplate` and `Biplate`, along with a number of functions. After importing `Data.Generics.Uniplate.Data` all types which have `Data`instances automatically have the necessary Uniplate instances. In the following subsections we introduce the Uniplate functions, along with examples of using them. The two most commonly used functions are `universe` (used for queries) and `transform` (used for transformations).++### Finding the constant values++```haskell+universe :: Uniplate on => on -> [on]+```++When manipulating our little language it may be useful to know which constants have been used. This can be done with the following code:++```haskell+constants :: Expr -> [Int]+constants x = nub [y | Val y <- universe x]+```++Here the only Uniplate method being used is `universe`, which when given a tree returns the root of the tree, and all its subtrees at all levels. This can be used to quickly flatten a tree structure into a list, for quick analysis via list comprehensions, as is done above.++_Exercise:_ Write a function to test if an expression performs a division by the literal zero.++### Basic optimisation++```haskell+transform :: Uniplate on => (on -> on) -> on -> on+```++If we are negating a literal value, this computation can be performed in advance, so let's write a function to do this.++```haskell+optimise :: Expr -> Expr+optimise = transform f+ where f (Neg (Val i)) = Val (negate i)+ f x = x+```++Here the Uniplate method being used is `transform`, which applies the given function to all the children of an expression, before applying it to the parent. This function can be thought of as bottom-up traversal of the data structure. The optimise code merely pattern matches on the negation of a literal, and replaces it with the literal.++Now let's add another optimisation into the same pass, just before the `f x = x` line insert:++```haskell+f (Add x y) | x == y = Mul x (Val 2)+```++This takes an addition where two terms are equal and changes it into a multiplication, causing the nested expression to be executed only once.++_Exercise:_ Extend the optimisation so that adding `x` to `Mul x (Val 2)` produces a multiplication by 3.++### Depth of an expression++```haskell+para :: Uniplate on => (on -> [res] -> res) -> on -> res+```++Now let's imagine that programmers in your language are paid by the depth of expression they produce, so let's write a function that computes the maximum depth of an expression.++```haskell+depth :: Expr -> Int+depth = para (\_ cs -> 1 + maximum (0:cs))+```++This function performs a paramorphism (a bit like a fold) over the data structure. The function simply says that for each iteration, add one to the previous depth.++_Exercise:_ Write a function that counts the maximum depth of addition only.++### Renumbering literals++```haskell+transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on+```++The literal values need to be replaced with a sequence of numbers, each unique. This is unlikely for an arithmetic expression, but consider bound variables in lambda calculus and it starts to become a bit more plausible:++```haskell+uniqueLits :: Expr -> Expr+uniqueLits x = evalState (transformM f x) [0..]+ where+ f (Val i) = do+ y:ys <- get+ put ys+ return (Val y)+ f x = return x+```++Here a monadic computation is required, the program needs to keep track of what the next item in the list to use is, and replace the current item. By using the state monad, this can be done easily.++_Exercise:_ Allow each literal to occur only once, when a second occurrence is detected, replace that literal with zero.++### Generating mutants++```haskell+contexts :: Uniplate on => on -> [(on, on -> on)]+```++The person who is inputting the expression thinks they made a mistake, they suspect they got one of the values wrong by plus or minus one. Generate all the expressions they might have written.++```haskell+mutate :: Expr -> [Expr]+mutate x = concat [[gen $ Val $ i-1, gen $ Val $ i+1]+ | (Val i, gen) <- contexts x]+```++The `transform` function is useful for doing an operation to all nodes in a tree, but sometimes you only want to apply a transformation once. This is less common, but is sometimes required. The idea is that the context provides the information required to recreate the original expression, but with this node altered.++_Exercise:_ Replace one multiplication with addition, if there are no multiplications return the original expression.++### Fixed point optimisation++```haskell+rewrite :: Uniplate on => (on -> Maybe on) -> on -> on+```++When slotting many transformations together, often one optimisation will enable another. For example, the the optimisation to reduce.++### Descend++Do something different in the odd and even cases. Particularly useful if you have free variables and are passing state downwards.++### Monadic Variants++```haskell+descendM :: Monad m => (on -> m on) -> on -> m on -- descend+transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on -- transform+rewriteM :: (Monad m, Uniplate on) => (on -> m (Maybe on)) -> on -> m on -- rewrite+```++All the transformations have both monadic and non-monadic versions.++### Single Depth Varaints++```haskell+children :: Uniplate on => on -> [on] -- universe+descend :: (on -> on) -> on -> on -- transform+holes :: Uniplate on => on -> [(on, on -> on)] -- contexts+```++Lots of functions which operate over the entire tree also operate over just one level. Usually you want to use the multiple level version, but when needing more explicit control the others are handy.++### Evaluation++If we need to evaluate an expression in our language, the answer is simple, don't use Uniplate! The reasons are that there is little boilerplate, you have to handle every case separately. For example in our language we can write:++```haskell+eval :: Expr -> Int+eval (Val i) = i+eval (Add a b) = eval a + eval b+eval (Sub a b) = eval a - eval b+eval (Div a b) = eval a `div` eval b+eval (Mul a b) = eval a * eval b+eval (Neg a) = negate a+```++## Using Biplate++All the operations defined in Uniplate have a corresponding Biplate instance. Typically the operations are just the same as Uniplate, with `Bi` on the end.++```haskell+universeBi :: Biplate on with => on -> [with]+transformBi :: Biplate on with => (with -> with) -> on -> on+transformBiM :: (Monad m, Biplate on with) => (with -> m with) -> on -> m on+```++The biggest difference is for the functions `childrenBi` and `descendBi`. In these cases, if the starting type and the target type are the same, then the input value will be returned. For example:++```haskell+childrenBi (Add (Val 1) (Val 2)) == [Add (Val 1) (Val 2)]+children (Add (Val 1) (Val 2)) == [Val 1, Val 2]+```++For example, you should never have `descendBi` in an inner recursive loop.++## Making Uniplate Faster++To make Uniplate faster import `Data.Generics.Uniplate.Direct` and write your instances by hand.++## Related work++* [Geniplate](http://hackage.haskell.org/package/geniplate), by Lennart Augustsson, Uniplate compatible but implemented using Template Haskell.+* [Refactoring Uniplate](http://www-ps.informatik.uni-kiel.de/~sebf/projects/traversal.html), by Sebastian Fischer - proposing a slightly different Uniplate API, but with the same underlying concepts.+* [Uniplate for Curry](http://www.informatik.uni-kiel.de/~pakcs/lib/CDOC/Traversal.html), by Sebastian Fischer - using his revised API as above.+* [Uniplate for ML (in MLton)](https://github.com/MLton/mltonlib/blob/master/com/ssh/generic/unstable/public/value/uniplate.sig), as part of the MLton generics library.+* [Uniplate for data types with embedded monads](http://tomschrijvers.blogspot.com/2007/11/extension-proposal-for-uniplate.html), by Tom Schrijvers+* [Multiplate](http://hackage.haskell.org/package/multiplate), by Russell O'Connor, similar ideas to Uniplate but with a very different underlying substrate.+* [Infer.Toys](https://infers.github.io/Infers/Infers.Toys.html) provides a Uniplate-inspired `Elems` module.
uniplate.cabal view
@@ -1,16 +1,17 @@-Cabal-Version: >= 1.2-Build-Type: Simple-Name: uniplate-Version: 1.5.1-Copyright: 2006-10, Neil Mitchell-Maintainer: ndmitchell@gmail.com-Homepage: http://community.haskell.org/~ndm/uniplate/-License: BSD3-License-File: LICENSE-Author: Neil Mitchell-Synopsis: Help writing simple, concise and fast generic operations.-Category: Generics-Description:+cabal-version: >= 1.18+build-type: Simple+name: uniplate+version: 1.6.13+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2006-2020+homepage: https://github.com/ndmitchell/uniplate#readme+bug-reports: https://github.com/ndmitchell/uniplate/issues+license: BSD3+license-file: LICENSE+synopsis: Help writing simple, concise and fast generic operations.+category: Generics+description: Uniplate is library for writing simple and concise generic operations. Uniplate has similar goals to the original Scrap Your Boilerplate work, but is substantially simpler and faster.@@ -30,6 +31,8 @@ . In addition, some users may want to make use of the following modules: .+ * "Data.Generics.Uniplate.Zipper" - a zipper built on top of Uniplate instances.+ . * "Data.Generics.SYB" - users transitioning from the Scrap Your Boilerplate library. . * "Data.Generics.Compos" - users transitioning from the Compos library.@@ -37,28 +40,36 @@ * "Data.Generics.Uniplate.DataOnly" - users making use of both @Data@ and @Direct@ to avoid getting instance conflicts. -Extra-Source-Files:- uniplate.htm+extra-source-files: Data/Generics/Uniplate/Internal/DataInc.hs Data/Generics/Uniplate/Internal/OperationsInc.hs+extra-doc-files:+ README.md+ CHANGES.txt+tested-with: GHC==8.10, GHC==8.8, GHC==8.6, GHC==8.4, GHC==8.2, GHC==8.0 -Flag ghc_6_10+source-repository head+ type: git+ location: https://github.com/ndmitchell/uniplate.git -Library- if flag(ghc_6_10)- build-depends: base >=4 && <5, mtl, containers, syb- else- build-depends: base >=3 && <4, mtl, containers+library+ default-language: Haskell2010+ build-depends:+ base >=4.4 && <5, containers, syb, ghc-prim,+ hashable >= 1.1.2.3,+ unordered-containers >= 0.2.1 - Exposed-modules:+ exposed-modules: Data.Generics.Str Data.Generics.Compos Data.Generics.SYB- Data.Generics.Uniplate.Operations- Data.Generics.Uniplate.Direct- Data.Generics.Uniplate.Typeable Data.Generics.Uniplate.Data+ Data.Generics.Uniplate.Data.Instances Data.Generics.Uniplate.DataOnly+ Data.Generics.Uniplate.Direct+ Data.Generics.Uniplate.Operations+ Data.Generics.Uniplate.Typeable+ Data.Generics.Uniplate.Zipper -- DEPRECATED Data.Generics.Uniplate@@ -70,10 +81,7 @@ Data.Generics.PlateTypeable Data.Generics.PlateData - Other-modules:- Data.Generics.PlateInternal+ other-modules: Data.Generics.Uniplate.Internal.Data Data.Generics.Uniplate.Internal.DataOnlyOperations Data.Generics.Uniplate.Internal.Utils-- Extensions: CPP
− uniplate.htm
@@ -1,265 +0,0 @@-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html>- <head>- <meta http-equiv="Content-Type" content="text/html;charset=utf-8" />- <title>Boilerplate Removal with Uniplate</title>- <style type="text/css">-pre {- border: 2px solid gray;- padding: 1px;- padding-left: 5px;- margin-left: 10px;- background-color: #eee;-}--pre.define {- background-color: #ffb;- border-color: #cc0;-}--body {- font-family: sans-serif;-}--h1, h2, h3 {- font-family: serif;-}--h1 {- color: rgb(23,54,93);- border-bottom: 1px solid rgb(79,129,189);- padding-bottom: 2px;- font-variant: small-caps;- text-align: center;-}--a {- color: rgb(54,95,145);-}--h2 {- color: rgb(54,95,145);-}--h3 {- color: rgb(79,129,189);-}- </style>- </head>- <body>--<h1>Boilerplate Removal with Uniplate</h1>--<p style="text-align:right;margin-bottom:25px;">- by <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a>-</p>--<p style="margin-left:10%;margin-right:10%;margin-bottom:25px;text-align:justify;">- Generic transformations and queries are often referred to as boilerplate code - they remain relatively similar as the action performed by the code changes, and can often outnumber the actual intent of the code in terms of lines. While other generic traversal schemes have shown how powerful new features can be added to compilers, and how the type system can be manipulated into accepting these operations, the Uniplate library focuses on a conceptually simpler generic concept. A more complete document on Uniplate was published at the Haskell Workshop 2007, and is available from the <a href="http://community.haskell.org/~ndm/uniplate/">project website</a>, along with a video presentation, and the associated thesis chapter.-</p>-<p>- Uniplate is a simple, concise and fast generics library. To expand on that sentence:-</p>-<ol>- <li>A generics library is one which allows you to write functions that operate over a data structure without tying down all aspects of the data structure. In particular, when writing an operation, you don't need to give a case for each constructor, and you don't have to state which fields are recursive.</li>- <li>Uniplate is the simplest generics library. Using Uniplate is within the reach of all Haskell programmers.</li>- <li>Uniplate is more concise than any other generics library.</li>- <li>Uniplate is fast, not always the absolute fastest, but massively faster than many generics libraries.</li>- <li>Uniplate is also less powerful than some other generics libraries, but if it does the job, you should use it.</li>-</ol>-<p>- The Uniplate library can be installed with the standard sequence of cabal commands:-</p>-<pre>-cabal update-cabal install uniplate-</pre>-<p>- This document proceeds as follows:-</p>-<ol>- <li>Using Uniplate</li>- <li>Using Biplate</li>- <li>Making Uniplate Faster</li>-</ol>--<h3>Acknowledgements</h3>--<p>- Thanks to Björn Bringert for feedback on an earlier version of this document, Eric Mertens for various ideas and code snippets, and to Matt Naylor and Tom Shackell for helpful discussions.-</p>---<h2>Using Uniplate</h2>--<p>- To demonstrate the facilities of Uniplate, we use a simple arithmetic type:-</p>-<pre>-<b>{-# LANGUAGE DerivingDataTypeable #-}</b>-module Expr where-<b>import Data.Generics.Uniplate.Data</b>--data Expr = Val Int- | Add Expr Expr- | Sub Expr Expr- | Div Expr Expr- | Mul Expr Expr- | Neg Expr- deriving (Show, Eq, <b>Data, Typeable</b>)-</pre>-<p>- In this definition, the Uniplate specific bits are bolded. The three extra parts are:-</p>-<ul>-<li><tt>import Data.Generics.Uniplate.Data</tt>, this module contains all the Uniplate functions and definitions.</li>-<li><tt>deriving (Data,Typeable)</tt>, this deriving clause automatically adds the necessary instances for Uniplate.</li>-<li><tt>{-# LANGUAGE DerivingDataTypeable #-}</tt>, this pragma turns on language support for the deriving line.</li>-</ul>-<p>- This definition makes use of the <a href="http://doi.acm.org/10.1145/604174.604179">Scrap Your Boilerplate (SYB) based</a> Uniplate implementation. The SYB implementation is compatible with the other implementations, but is slower (between 2 and 8 times) and requires some modest compiler extensions (implemented in <a href="http://haskell.org/ghc/">GHC</a> for many years). The alternative definition scheme is described towards the end of this document, in "Making Uniplate Faster". I recommend using the SYB implementation to start with, as it requires least setup.-</p>--<h3>Checking for division by zero</h3>--<pre class="define">-universe :: Uniplate on => on -> [on]-</pre>-<p>- If an expression is divided by zero, this causes a runtime error in our language. As part of the compiler, it's nice to give the user a warning message about this. This can be done with the following test:-</p>-<pre>-hasDivZero :: Expr -> Bool-hasDivZero x = not $ null [() | Div _ (Val 0) <- universe x]-</pre>-<p>- Here the only Uniplate method being used is <tt>universe</tt>. Given a tree, <tt>universe</tt> returns all the root of the tree, and all it's subtrees at all levels. This can be used to quickly flatten a tree structure into a list, for quick analysis via list comprehensions, as is done above. For each division by zero found, any value is created in the list comprehension, and then this is checked to see if anything did match. Returning the count of divide by zero errors is trivial, simply use <tt>length</tt> instead of <tt>not $ null</tt>. Extra context could perhaps be given by printing some of the value that is being divided by zero, to help narrow down the error.-</p>-<p>- <i>Exercise:</i> Write a function to find all literals that occur in an expression, together with their count.-</p>--<h3>Basic optimisation</h3>--<pre class="define">-transform :: Uniplate on => (on -> on) -> on -> on-</pre>-<p>- If we are negating a literal value, this computation can be performed in advance, so let's write a function to do this.-</p>-<pre>-optimise :: Expr -> Expr-optimise = transform f- where f (Neg (Val i)) = Val (negate i)- f x = x-</pre>-<p>- Here the Uniplate method being used is <tt>transform</tt>. This applies the given function to all the children of an expression, before applying it to the parent. This can be thought of as bottom-up traversal of the data structure. The optimise code merely pattern matches on the negation of a literal, and replaces it with the literal.-</p>-<p>- Now lets add another optimisation into the same pass, just before the <tt>f x = x</tt> line insert:-</p>-<pre>- f (Add x y) | x == y = Mul x (Val 2)-</pre>-<p>- This takes an addition where two terms are equal and changes it into a multiplication, causing the nested expression to be executed only once. This shows that normal Haskell applies, the Uniplate lets you write code as before.-</p>-<p>- <i>Exercise:</i> Extend the optimisation to so that adding <tt>x</tt> to <tt>Mul x (Val 2)</tt> produces a multiplication by 3.-</p>---<h3>Depth of an expression</h3>--<pre class="define">-para :: Uniplate on => (on -> [res] -> res) -> on -> res-</pre>-<p>- Now lets imagine that programmers in your language are paid by the depth of expression they produce, so lets write a function that computes the maximum depth of an expression.-</p>-<pre>-depth :: Expr -> Int-depth = para (\_ cs -> 1 + maximum (0:cs))-</pre>-<p>- This function performs a paramorphism (a bit like a fold) over the data structure. The function simply says that for each iteration, add one to the previous depth. An evaluator for this expression language can also be modelled as a <tt>para</tt>, see inside the example directory to see an implementation.-</p>-<p>- <i>Exercise:</i> Write a function that counts the maximum depth of addition only.-</p>--<h3>Renumbering literals</h3>--<pre class="define">-transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on-</pre>-<p>- The literal values need to be replaced with a sequence of numbers, each unique. This is unlikely for an arithmetic expression, but consider bound variables in lambda calculus and it starts to become a bit more plausible:-</p>-<pre>-uniqueLits :: Expr -> Expr-uniqueLits x = evalState (transformM f x) [0..]- where- f (Val i) = do- y:ys <- get- put ys- return (Val y)- f x = return x-</pre>-<p>- Here a monadic computation is required, the program needs to keep track of what the next item in the list to use is, and replace the current item. By using the state monad, this can be done easily.-</p>-<p>- <i>Exercise:</i> Allow each literal to occur only once, when a second occurance is detected, replace that literal with zero.-</p>--<h3>Generating mutants</h3>--<pre class="define">-contexts :: Uniplate on => on -> [(on, on -> on)]-</pre>-<p>- The person who is inputting the expression thinks they made a mistake, they suspect they got one of the values wrong by plus or minus one. Generate all the expressions they might have written.-</p>-<pre>-mutate :: Expr -> [Expr]-mutate x = concat [[gen $ Val $ i-1, gen $ Val $ i+1]- | (Val i, gen) <- contexts x]-</pre>-<p>- The <tt>transform</tt> function is useful for doing an operation to all nodes in a tree, but sometimes you only want to apply a transformation once. This is less common, but is sometimes required. The idea is that the context provides the information required to recreate the original expression, but with this node altered.-</p>-<p>- <i>Exercise:</i> Replace one multiplication with addition, if there are no multiplications return the original expression.-</p>---<h3>Using Biplate</h3>--<p>- All the operations defined in Uniplate have a corresponding Biplate instance. Typically the operations are just the same as Uniplate, with <tt>Bi</tt> on the end.-</p>-<pre class="define">-universeBi:: Biplate on with => on -> [with]-transformBi :: Biplate on with => (with -> with) -> on -> on-transformBiM :: (Monad m, Biplate on with) => (with -> m with) -> on -> m on-</pre>-<p>- The biggest difference is for the functions <tt>childrenBi</tt> and <tt>descendBi</tt>. In these cases, if the starting type and the target type are the same, then the input value will be returned. For example:-</p>-<pre>-childrenBi (Add (Val 1) (Val 2)) == [Add (Val 1) (Val 2)]-children (Add (Val 1) (Val 2)) == [Val 1, Val 2]-</pre>--<h3>Making Uniplate Faster</h3>--<p>- To make Uniplate faster import <tt>Data.Generics.Uniplate.Direct</tt>, and provide Uniplate instances by generating them with the <a href="http://community.haskell.org/~ndm/derive/">Derive tool</a>.-</p>--- </body>-</html>