uniplate-1.6.11/ 0000755 0000000 0000000 00000000000 12202721612 011602 5 ustar 00 0000000 0000000 uniplate-1.6.11/uniplate.htm 0000644 0000000 0000000 00000027712 12202721612 014146 0 ustar 00 0000000 0000000
Boilerplate Removal with Uniplate
Boilerplate Removal with Uniplate
by Neil Mitchell
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 project website, along with a video presentation, and the associated thesis chapter.
Uniplate is a simple, concise and fast generics library. To expand on that sentence:
- 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.
- Uniplate is the simplest generics library. Using Uniplate is within the reach of all Haskell programmers.
- Uniplate is more concise than any other generics library.
- Uniplate is fast, not always the absolute fastest, but massively faster than many generics libraries.
- 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:
- Using Uniplate
- Using Biplate
- 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:
{-# LANGUAGE DerivingDataTypeable #-}
module Expr where
import Data.Generics.Uniplate.Data
data Expr = Val Int
| Add Expr Expr
| Sub Expr Expr
| Div Expr Expr
| Mul Expr Expr
| Neg Expr
deriving (Show, Eq, Data, Typeable)
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 DerivingDataTypeable #-}, this pragma turns on language support for the deriving line.
This definition makes use of the Scrap Your Boilerplate (SYB) 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 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
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:
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 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.
Exercise: Write a function to test if an expression performs a division by the literal zero.
Basic optimisation
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.
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 lets add another optimisation into the same pass, just before the f x = x line insert:
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 to so that adding x to Mul x (Val 2) produces a multiplication by 3.
Depth of an expression
para :: Uniplate on => (on -> [res] -> res) -> on -> res
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.
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
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:
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 occurance is detected, replace that literal with zero.
Generating mutants
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.
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
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
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
children :: Uniplate on => on -> [on] -- universe
descend :: (on -> on) -> on -> on -- transform
holes :: Uniplate on => on -> [(on, on -> on)] -- contexts
Lot's 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
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:
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.
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:
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 hvae descendBi in an inner recursive loop.
Making Uniplate Faster
To make Uniplate faster import Data.Generics.Uniplate.Direct, and provide Uniplate instances by generating them with the Derive tool.
uniplate-1.6.11/uniplate.cabal 0000644 0000000 0000000 00000006530 12202721612 014413 0 ustar 00 0000000 0000000 cabal-version: >= 1.6
build-type: Simple
name: uniplate
version: 1.6.11
author: Neil Mitchell
maintainer: Neil Mitchell
copyright: Neil Mitchell 2006-2013
homepage: http://community.haskell.org/~ndm/uniplate/
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. The Uniplate manual is available at
.
.
To get started with Uniplate you should import one of the three following
modules:
.
* "Data.Generics.Uniplate.Data" - to quickly start writing generic functions.
Most users should start by importing this module.
.
* "Data.Generics.Uniplate.Direct" - a replacement for "Data.Generics.Uniplate.Data"
with substantially higher performance (around 5 times), but requires writing
instance declarations.
.
* "Data.Generics.Uniplate.Operations" - definitions of all the operations defined
by Uniplate. Both the above two modules re-export this module.
.
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.
.
* "Data.Generics.Uniplate.DataOnly" - users making use of both @Data@ and @Direct@
to avoid getting instance conflicts.
extra-source-files:
uniplate.htm
Data/Generics/Uniplate/Internal/DataInc.hs
Data/Generics/Uniplate/Internal/OperationsInc.hs
source-repository head
type: darcs
location: http://community.haskell.org/~ndm/darcs/uniplate/
flag typeable_fingerprint
flag separate_syb
library
if flag(typeable_fingerprint)
build-depends:
base >=4.4 && <5, containers, syb,
hashable >= 1.1.2.3 && < 1.3,
unordered-containers >= 0.2.1 && < 0.3
else
if flag(separate_syb)
build-depends: base >=4 && <4.4, containers, syb
else
build-depends: base >=3 && <4, containers
exposed-modules:
Data.Generics.Str
Data.Generics.Compos
Data.Generics.SYB
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
Data.Generics.UniplateOn
Data.Generics.UniplateStr
Data.Generics.UniplateStrOn
Data.Generics.Biplate
Data.Generics.PlateDirect
Data.Generics.PlateTypeable
Data.Generics.PlateData
other-modules:
Data.Generics.Uniplate.Internal.Data
Data.Generics.Uniplate.Internal.DataOnlyOperations
Data.Generics.Uniplate.Internal.Utils
extensions: CPP
uniplate-1.6.11/Setup.hs 0000644 0000000 0000000 00000000055 12202721612 013236 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain uniplate-1.6.11/LICENSE 0000644 0000000 0000000 00000002764 12202721612 012620 0 ustar 00 0000000 0000000 Copyright Neil Mitchell 2006-2013.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Neil Mitchell nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
uniplate-1.6.11/Data/ 0000755 0000000 0000000 00000000000 12202721612 012453 5 ustar 00 0000000 0000000 uniplate-1.6.11/Data/Generics/ 0000755 0000000 0000000 00000000000 12202721612 014212 5 ustar 00 0000000 0000000 uniplate-1.6.11/Data/Generics/UniplateStrOn.hs 0000644 0000000 0000000 00000007701 12202721612 017322 0 ustar 00 0000000 0000000 {- |
/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".
The only function missing from "Data.Generics.Uniplate" is 'fold', as it can be
constructed from 'children' and has little meaning in a multi-typed setting.
All operations, apart from 'childrenOn', 'descendOn' and 'holesOn' should perform
identically to their non @On@ counterparts.
-}
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.Traversable
import Prelude hiding (mapM)
import Data.Generics.Uniplate.Internal.Utils
import Data.Generics.Str
import Data.Generics.UniplateStr
-- * Types
-- | 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.
type BiplateType from to = from -> (Str to, Str to -> from)
-- * Operations
-- ** Queries
universeOn :: Uniplate to => BiplateType from to -> from -> [to]
universeOn biplate x = builder f
where
f cons nil = g cons nil (fst $ biplate x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` g cons nil (fst $ uniplate x) res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- | Return the children of a type. If @to == from@ then it returns the
-- original element (in contrast to 'children')
childrenOn :: Uniplate to => BiplateType from to -> from -> [to]
childrenOn biplate x = builder f
where
f cons nil = g cons nil (fst $ biplate x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- ** Transformations
transformOn :: Uniplate to => BiplateType from to -> (to -> to) -> from -> from
transformOn biplate f x = generate $ fmap (transform f) current
where (current, generate) = biplate x
transformOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m to) -> from -> m from
transformOnM biplate f x = liftM generate $ mapM (transformM f) current
where (current, generate) = biplate x
rewriteOn :: Uniplate to => BiplateType from to -> (to -> Maybe to) -> from -> from
rewriteOn biplate f x = generate $ fmap (rewrite f) current
where (current, generate) = biplate x
rewriteOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m (Maybe to)) -> from -> m from
rewriteOnM biplate f x = liftM generate $ mapM (rewriteM f) current
where (current, generate) = biplate x
descendOn :: Uniplate to => BiplateType from to -> (to -> to) -> from -> from
descendOn biplate f x = generate $ fmap f current
where (current, generate) = biplate x
descendOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m to) -> from -> m from
descendOnM biplate f x = liftM generate $ mapM f current
where (current, generate) = biplate x
-- ** Other
holesOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)]
holesOn biplate x = uncurry f (biplate x)
where f Zero _ = []
f (One i) generate = [(i, generate . One)]
f (Two l r) gen = f l (gen . (\i -> Two i r))
++ f r (gen . (\i -> Two l i))
contextsOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)]
contextsOn biplate x = f (holesOn biplate x)
where
f xs = [ (y, ctx . context)
| (child, ctx) <- xs
, (y, context) <- contexts child]
-- * Helper for writing instances
-- | Used for defining instances @UniplateFoo a => UniplateFoo [a]@
uniplateOnList :: BiplateType a b -> BiplateType [a] b
uniplateOnList f [] = (Zero, \_ -> [])
uniplateOnList f (x:xs) =
(Two a as,
\(Two n ns) -> b n : bs ns)
where
(a , b ) = f x
(as, bs) = uniplateOnList f xs
uniplate-1.6.11/Data/Generics/UniplateStr.hs 0000644 0000000 0000000 00000013334 12202721612 017024 0 ustar 00 0000000 0000000 {- |
/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.
Most functions have an example of a possible use for the function.
To illustate, I have used the @Expr@ type as below:
> data Expr = Val Int
> | Neg Expr
> | Add Expr Expr
-}
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.Traversable
import Prelude hiding (mapM)
import Data.Generics.Uniplate.Internal.Utils
import Data.Generics.Str
-- * The Class
-- | The type of replacing all the children of a node
--
-- Taking a value, the function should return all the immediate children
-- of the same type, and a function to replace them.
type UniplateType on = on -> (Str on, Str on -> on)
-- | The standard Uniplate class, all operations require this.
class Uniplate on where
-- | The underlying method in the class.
--
-- Given @uniplate x = (cs, gen)@
--
-- @cs@ should be a @Str on@, constructed of @Zero@, @One@ and @Two@,
-- containing all @x@'s direct children of the same type as @x@. @gen@
-- should take a @Str on@ with exactly the same structure as @cs@,
-- and generate a new element with the children replaced.
--
-- Example instance:
--
-- > instance Uniplate Expr where
-- > uniplate (Val i ) = (Zero , \Zero -> Val i )
-- > uniplate (Neg a ) = (One a , \(One a) -> Neg a )
-- > uniplate (Add a b) = (Two (One a) (One b), \(Two (One a) (One b)) -> Add a b)
uniplate :: UniplateType on
-- | Compatibility method, for direct users of the old list-based 'uniplate' function
uniplateList :: Uniplate on => on -> ([on], [on] -> on)
uniplateList x = (c, b . d)
where
(a,b) = uniplate x
(c,d) = strStructure a
-- * The Operations
-- ** Queries
-- | Get all the children of a node, including itself and all children.
--
-- > universe (Add (Val 1) (Neg (Val 2))) =
-- > [Add (Val 1) (Neg (Val 2)), Val 1, Neg (Val 2), Val 2]
--
-- This method is often combined with a list comprehension, for example:
--
-- > vals x = [i | Val i <- universe x]
universe :: Uniplate on => on -> [on]
universe x = builder f
where
f cons nil = g cons nil (One x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` g cons nil (fst $ uniplate x) res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- | Get the direct children of a node. Usually using 'universe' is more appropriate.
--
-- @children = fst . 'uniplate'@
children :: Uniplate on => on -> [on]
children x = builder f
where
f cons nil = g cons nil (fst $ uniplate x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- ** Transformations
-- | Transform every element in the tree, in a bottom-up manner.
--
-- For example, replacing negative literals with literals:
--
-- > negLits = transform f
-- > where f (Neg (Lit i)) = Lit (negate i)
-- > f x = x
transform :: Uniplate on => (on -> on) -> on -> on
transform f = f . descend (transform f)
-- | Monadic variant of 'transform'
transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on
transformM f x = f =<< descendM (transformM f) x
-- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot
-- be applied anywhere in the result:
--
-- > propRewrite r x = all (isNothing . r) (universe (rewrite r x))
--
-- Usually 'transform' is more appropriate, but 'rewrite' can give better
-- compositionality. Given two single transformations @f@ and @g@, you can
-- construct @f `mplus` g@ which performs both rewrites until a fixed point.
rewrite :: Uniplate on => (on -> Maybe on) -> on -> on
rewrite f = transform g
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
rewriteM f = transformM g
where g x = f x >>= maybe (return x) (rewriteM f)
-- | 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.
descend :: Uniplate on => (on -> on) -> on -> on
descend f x = generate $ fmap f current
where (current, generate) = uniplate x
-- | 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
-- ** Others
-- | Return all the contexts and holes.
--
-- > propUniverse x = universe x == map fst (contexts x)
-- > propId x = all (== x) [b a | (a,b) <- contexts x]
contexts :: Uniplate on => on -> [(on, on -> on)]
contexts x = (x,id) : f (holes x)
where
f xs = [ (y, ctx . context)
| (child, ctx) <- xs
, (y, context) <- contexts child]
-- | The one depth version of 'contexts'
--
-- > propChildren x = children x == map fst (holes x)
-- > propId 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 _ = []
f (One i) generate = [(i, generate . One)]
f (Two l r) gen = f l (gen . (\i -> Two i r))
++ f r (gen . (\i -> Two l i))
-- | Perform a fold-like computation on each value,
-- technically a paramorphism
para :: Uniplate on => (on -> [r] -> r) -> on -> r
para op x = op x $ map (para op) $ children x
uniplate-1.6.11/Data/Generics/UniplateOn.hs 0000644 0000000 0000000 00000006565 12202721612 016640 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-deprecations #-}
{- |
/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".
The only function missing from "Data.Generics.Uniplate" is 'fold', as it can be
constructed from 'children' and has little meaning in a multi-typed setting.
All operations, apart from 'childrenOn' should perform identically to their non @On@
counterparts.
-}
module Data.Generics.UniplateOn
{- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -}
(
module Data.Generics.Uniplate,
module Data.Generics.UniplateOn
) where
import Data.Generics.Uniplate
import Control.Monad(liftM)
-- * Types
-- | 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.
type BiplateType from to = from -> ([to], [to] -> from)
-- * Operations
-- ** Queries
universeOn :: Uniplate to => BiplateType from to -> from -> [to]
universeOn biplate x = concatMap universe $ fst $ biplate x
-- | Return the children of a type. If @to == from@ then it returns the
-- original element (in contrast to 'children')
childrenOn :: Uniplate to => BiplateType from to -> from -> [to]
childrenOn biplate x = fst $ biplate x
-- ** Transformations
transformOn :: Uniplate to => BiplateType from to -> (to -> to) -> from -> from
transformOn biplate f x = generate $ map (transform f) current
where (current, generate) = biplate x
transformOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m to) -> from -> m from
transformOnM biplate f x = liftM generate $ mapM (transformM f) current
where (current, generate) = biplate x
rewriteOn :: Uniplate to => BiplateType from to -> (to -> Maybe to) -> from -> from
rewriteOn biplate f x = generate $ map (rewrite f) current
where (current, generate) = biplate x
rewriteOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m (Maybe to)) -> from -> m from
rewriteOnM biplate f x = liftM generate $ mapM (rewriteM f) current
where (current, generate) = biplate x
descendOn :: Uniplate to => BiplateType from to -> (to -> to) -> from -> from
descendOn biplate f x = generate $ map f current
where (current, generate) = biplate x
descendOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m to) -> from -> m from
descendOnM biplate f x = liftM generate $ mapM f current
where (current, generate) = biplate x
-- ** Other
holesOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)]
holesOn biplate x = uncurry f (biplate x)
where f [] _ = []
f (x:xs) gen = (x, gen . (:xs)) :
f xs (gen . (x:))
contextsOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)]
contextsOn biplate x = f (holesOn biplate x)
where
f xs = [ (y, ctx . context)
| (child, ctx) <- xs
, (y, context) <- contexts child]
-- * Helper for writing instances
-- | Used for defining instances @UniplateFoo a => UniplateFoo [a]@
uniplateOnList :: BiplateType a b -> BiplateType [a] b
uniplateOnList f [] = ([], \[] -> [])
uniplateOnList f (x:xs) =
(a ++ as,
\ns -> let (n1,n2) = splitAt (length a) ns in b n1 : bs n2)
where
(a , b ) = f x
(as, bs) = uniplateOnList f xs
uniplate-1.6.11/Data/Generics/Uniplate.hs 0000644 0000000 0000000 00000011125 12202721612 016327 0 ustar 00 0000000 0000000 {- |
/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.
Most functions have an example of a possible use for the function.
To illustate, I have used the @Expr@ type as below:
> data Expr = Val Int
> | Neg Expr
> | Add Expr Expr
-}
module Data.Generics.Uniplate
{- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -}
where
import Control.Monad
import Data.Generics.Uniplate.Internal.Utils
-- * The Class
-- | The type of replacing all the children of a node
--
-- Taking a value, the function should return all the immediate children
-- of the same type, and a function to replace them.
type UniplateType on = on -> ([on], [on] -> on)
-- | The standard Uniplate class, all operations require this
class Uniplate on where
-- | The underlying method in the class
--
-- > 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
-- | Get all the children of a node, including itself and all children.
--
-- > universe (Add (Val 1) (Neg (Val 2))) =
-- > [Add (Val 1) (Neg (Val 2)), Val 1, Neg (Val 2), Val 2]
--
-- This method is often combined with a list comprehension, for example:
--
-- > vals x = [i | Val i <- universe x]
universe :: Uniplate on => on -> [on]
universe x = builder (f x)
where
f :: Uniplate on => on -> (on -> res -> res) -> res -> res
f x cons nil = x `cons` concatCont (map (\x -> f x cons) $ children x) nil
-- | Get the direct children of a node. Usually using 'universe' is more appropriate.
--
-- @children = fst . 'uniplate'@
children :: Uniplate on => on -> [on]
children = fst . uniplate
-- ** Transformations
-- | Transform every element in the tree, in a bottom-up manner.
--
-- For example, replacing negative literals with literals:
--
-- > negLits = transform f
-- > where f (Neg (Lit i)) = Lit (negate i)
-- > f x = x
transform :: Uniplate on => (on -> on) -> on -> on
transform f x = f $ generate $ map (transform f) current
where (current, generate) = uniplate x
-- | Monadic variant of 'transform'
transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on
transformM f x = mapM (transformM f) current >>= f . generate
where (current, generate) = uniplate x
-- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot
-- be applied anywhere in the result:
--
-- > propRewrite r x = all (isNothing . r) (universe (rewrite r x))
--
-- Usually 'transform' is more appropriate, but 'rewrite' can give better
-- compositionality. Given two single transformations @f@ and @g@, you can
-- construct @f `mplus` g@ which performs both rewrites until a fixed point.
rewrite :: Uniplate on => (on -> Maybe on) -> on -> on
rewrite f = transform g
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
rewriteM f = transformM g
where g x = f x >>= maybe (return x) (rewriteM f)
-- | 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.
descend :: Uniplate on => (on -> on) -> on -> on
descend f x = generate $ map f current
where (current, generate) = uniplate x
-- | 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
-- ** Others
-- | Return all the contexts and holes.
--
-- > propUniverse x = universe x == map fst (contexts x)
-- > propId x = all (== x) [b a | (a,b) <- contexts x]
contexts :: Uniplate on => on -> [(on, on -> on)]
contexts x = (x,id) : f (holes x)
where
f xs = [ (y, ctx . context)
| (child, ctx) <- xs
, (y, context) <- contexts child]
-- | The one depth version of 'contexts'
--
-- > propChildren x = children x == map fst (holes x)
-- > propId x = all (== x) [b a | (a,b) <- holes x]
holes :: Uniplate on => on -> [(on, on -> on)]
holes x = uncurry f (uniplate x)
where f [] _ = []
f (x:xs) gen = (x, gen . (:xs)) :
f xs (gen . (x:))
-- | Perform a fold-like computation on each value,
-- technically a paramorphism
para :: Uniplate on => (on -> [r] -> r) -> on -> r
para op x = op x $ map (para op) $ children x
uniplate-1.6.11/Data/Generics/SYB.hs 0000644 0000000 0000000 00000004027 12202721612 015206 0 ustar 00 0000000 0000000 {-|
SYB compatibility layer. This module serves as a drop-in
replacement in some situations for some of the SYB operations.
Users should also import "Data.Generics.Uniplate.Data".
SYB is described in the paper: \"Scrap your boilerplate: a practical design
pattern for generic programming\" by Ralf Lammel and Simon
Peyton Jones.
*
*
*
-}
module Data.Generics.SYB where
import Data.Generics.Uniplate.Operations
-- | @gmapT == 'descend'@
gmapT :: Uniplate a => (a -> a) -> a -> a
gmapT = descend
-- | Use 'children' and 'foldl'
gmapQl :: Uniplate a => (r -> r' -> r) -> r -> (a -> r') -> a -> r
gmapQl combine zero op = foldl combine zero . map op . children
-- | Use 'children' and 'foldr'
gmapQr :: Uniplate a => (r' -> r -> r) -> r -> (a -> r') -> a -> r
gmapQr combine zero op = foldr combine zero . map op . children
-- | Use 'children'
gmapQ :: Uniplate a => (a -> u) -> a -> [u]
gmapQ f = map f . children
-- | Use 'children' and '!!'
gmapQi :: Uniplate a => Int -> (a -> u) -> a -> u
gmapQi i f x = gmapQ f x !! i
-- | @gmapM == 'descendM'@
gmapM :: (Uniplate a, Monad m) => (a -> m a) -> a -> m a
gmapM = descendM
-- | @mkT == 'id'@
mkT :: (a -> a) -> (a -> a)
mkT = id
-- | @everywhere == 'transformBi'@
everywhere :: Biplate b a => (a -> a) -> b -> b
everywhere = transformBi
-- | @mkM == id@
mkM :: Monad m => (a -> m a) -> a -> m a
mkM = id
-- | @everywhereM == 'transformBiM'@
everywhereM :: (Biplate b a, Monad m) => (a -> m a) -> b -> m b
everywhereM = transformBiM
-- | Only for use with 'everything'
mkQ :: r -> (a -> r) -> (r, a -> r)
mkQ = (,)
-- | Use 'universe' or 'universeBi', perhaps followed by a fold.
--
-- Not an exact equivalent to the SYB @everything@, as the
-- operators may be applied in different orders.
everything :: Biplate b a => (r -> r -> r) -> (r, a -> r) -> b -> r
everything combine (nil, op) = foldl combine nil . map op . universeBi
uniplate-1.6.11/Data/Generics/Str.hs 0000644 0000000 0000000 00000005152 12202721612 015321 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{- |
This module provides the 'Str' data type, which is used by the
underlying 'uniplate' and 'biplate' methods. It should not
be used directly under normal circumstances.
-}
module Data.Generics.Str where
import Data.Generics.Uniplate.Internal.Utils
import Control.Applicative
import Control.Monad
import Data.Foldable
import Data.Monoid
import Data.Traversable
-- * 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 :: Monad m => (a -> m b) -> Str a -> m (Str b)
strMapM f x = g SPEC x
where
g !spec Zero = return Zero
g !spec (One x) = liftM One $ f x
g !spec (Two x y) = liftM2 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)
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
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
-- | Take the type of the method, will crash if called
strType :: Str a -> a
strType = error "Data.Generics.Str.strType: Cannot be called"
-- | Convert a 'Str' to a list, assumes the value was created
-- with 'listStr'
strList :: Str a -> [a]
strList x = builder (f x)
where
f (Two (One x) xs) cons nil = x `cons` f xs cons nil
f Zero cons nil = nil
-- | Convert a list to a 'Str'
listStr :: [a] -> Str a
listStr (x:xs) = Two (One x) (listStr xs)
listStr [] = Zero
-- | Transform a 'Str' to a list, and back again, in a structure
-- preserving way. The output and input lists must be equal in
-- length.
strStructure :: Str a -> ([a], [a] -> Str a)
strStructure x = (g x [], fst . f x)
where
g :: Str a -> [a] -> [a]
g Zero xs = xs
g (One x) xs = x:xs
g (Two a b) xs = g a (g b xs)
f :: Str a -> [a] -> (Str a, [a])
f Zero rs = (Zero, rs)
f (One _) (r:rs) = (One r, rs)
f (Two a b) rs1 = (Two a2 b2, rs3)
where
(a2,rs2) = f a rs1
(b2,rs3) = f b rs2
uniplate-1.6.11/Data/Generics/PlateTypeable.hs 0000644 0000000 0000000 00000011553 12202721612 017306 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
{- |
/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 ...
>
> instance (Typeable a, Uniplate a) => PlateAll Expr a where
> plateAll (Var x ) = plate Var |- x
> plateAll (Neg x ) = plate Neg |+ x
> plateAll (Add x y) = plate Add |+ x |+ y
>
> instance Uniplate Expr where
> uniplate = uniplateAll
-}
module Data.Generics.PlateTypeable
{-# DEPRECATED "Use Data.Generics.Uniplate.Typeable instead" #-}
(
module Data.Generics.Biplate,
module Data.Typeable,
-- * The Class
PlateAll(..), uniplateAll,
-- * The Combinators
plate, (|+), (|-)
) where
import Data.Generics.Biplate
import Data.Generics.Uniplate.Internal.Utils
import Data.Typeable
instance (Typeable a, Typeable b, Uniplate b, PlateAll a b) => Biplate a b where
biplate = plateMore
-- | This function is used to write a 'Uniplate' instance from a 'PlateAll' one
uniplateAll :: PlateAll a b => a -> (Str b, Str b -> a)
uniplateAll = plateAll
type Type from to = (Str to, Str to -> from)
plateMore :: (Typeable from, Typeable to, PlateAll from to) => from -> Type from to
plateMore x = res
where
res = case asTypeOf (cast x) (Just $ strType $ fst res) of
Nothing -> plateAll x
Just y -> (One y, \(One y) -> unsafeCoerce y)
-- | This class represents going from the container type to the target.
--
-- This class should only be constructed with 'plate', '|+' and '|-'
class PlateAll from to where
plateAll :: from -> Type from to
-- | The main combinator used to start the chain.
--
-- The following rule can be used for optimisation:
--
-- > plate Ctor |- x == plate (Ctor x)
plate :: from -> Type from to
plate x = (Zero, \_ -> x)
-- | the field to the right may contain the target.
(|+) :: (Typeable item, Typeable to, PlateAll item to) => Type (item -> from) to -> item -> Type from to
(|+) (xs,x_) y = case plateMore y of
(ys,y_) -> (Two xs ys,\(Two xs ys) -> x_ xs (y_ ys))
-- | The field to the right /does not/ contain the target.
-- This can be used as either an optimisation, or more commonly for excluding
-- primitives such as Int.
(|-) :: Type (item -> from) to -> item -> Type from to
(|-) (xs,x_) y = (xs,\xs -> x_ xs y)
-- * Instances
-- ** Primitive Types
instance PlateAll Int to where plateAll x = plate x
instance Uniplate Int where uniplate = uniplateAll
instance PlateAll Bool to where plateAll x = plate x
instance Uniplate Bool where uniplate = uniplateAll
instance PlateAll Char to where plateAll x = plate x
instance Uniplate Char where uniplate = uniplateAll
instance PlateAll Integer to where plateAll x = plate x
instance Uniplate Integer where uniplate = uniplateAll
instance PlateAll Double to where plateAll x = plate x
instance Uniplate Double where uniplate = uniplateAll
instance PlateAll Float to where plateAll x = plate x
instance Uniplate Float where uniplate = uniplateAll
instance PlateAll () to where plateAll x = plate x
instance Uniplate () where uniplate = uniplateAll
-- ** Container Types
instance (PlateAll from to, Typeable from, Typeable to, Uniplate to) => PlateAll [from] to where
plateAll [] = plate []
plateAll (x:xs) = plate (:) |+ x |+ xs
instance (PlateAll from to, Typeable from, Typeable to, Uniplate to) => PlateAll (Maybe from) to where
plateAll Nothing = plate Nothing
plateAll (Just x) = plate Just |+ x
instance (PlateAll a to, Typeable a, PlateAll b to, Typeable b, Typeable to, Uniplate to) =>
PlateAll (Either a b) to where
plateAll (Left x) = plate Left |+ x
plateAll (Right x) = plate Right |+ x
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,Typeable to, Uniplate to) =>
PlateAll (a,b) to where
plateAll (a,b) = plate (,) |+ a |+ b
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,PlateAll c to, Typeable c
,Typeable to, Uniplate to) =>
PlateAll (a,b,c) to where
plateAll (a,b,c) = plate (,,) |+ a |+ b |+ c
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,PlateAll c to, Typeable c
,PlateAll d to, Typeable d
,Typeable to, Uniplate to) =>
PlateAll (a,b,c,d) to where
plateAll (a,b,c,d) = plate (,,,) |+ a |+ b |+ c |+ d
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,PlateAll c to, Typeable c
,PlateAll d to, Typeable d
,PlateAll e to, Typeable e
,Typeable to, Uniplate to) =>
PlateAll (a,b,c,d,e) to where
plateAll (a,b,c,d,e) = plate (,,,,) |+ a |+ b |+ c |+ d |+ e
uniplate-1.6.11/Data/Generics/PlateDirect.hs 0000644 0000000 0000000 00000005665 12202721612 016762 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses #-}
{- |
/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
>
> instance Uniplate Expr where
> uniplate (Var x ) = plate Var |- x
> uniplate (Pos x y) = plate Pos |* x |- y
> uniplate (Neg x ) = plate Neg |* x
> uniplate (Add x y) = plate Add |* x |* y
>
> instance Biplate Expr Expr where
> biplate = plateSelf
>
> instance Uniplate Stmt where
> uniplate (Seq x ) = plate Seq ||* x
> uniplate (Sel x ) = plate Sel ||+ x
> uniplate (Let x y) = plate Let |- x |- y
>
> instance Biplate Stmt Stmt where
> biplate = plateSelf
>
> instance Biplate Stmt Expr where
> biplate (Seq x ) = plate Seq ||+ x
> biplate (Sel x ) = plate Sel ||* x
> biplate (Let x y) = plate Let |- x |* y
-}
module Data.Generics.PlateDirect
{-# DEPRECATED "Use Data.Generics.Uniplate.Direct instead" #-}
(
module Data.Generics.Biplate,
-- * The Combinators
plate, plateSelf,
(|+), (|-), (|*), (||+), (||*)
) where
import Data.Generics.Biplate
type Type from to = (Str to, Str to -> from)
-- | The main combinator used to start the chain.
--
-- The following rule can be used for optimisation:
--
-- > plate Ctor |- x == plate (Ctor x)
plate :: from -> Type from to
plate f = (Zero, \_ -> f)
-- | The field to the right is the target.
(|*) :: 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.
(|+) :: 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.
(|-) :: Type (item -> from) to -> item -> Type from to
(|-) (xs,x_) y = (xs,\xs -> x_ xs y)
-- | The field to the right is a list of the type of the target
(||*) :: Type ([to] -> from) to -> [to] -> Type from to
(||*) (xs,x_) y = (Two xs (listStr y), \(Two xs ys) -> x_ xs (strList ys))
-- | The field to the right is a list of types which may contain the target
(||+) :: Biplate item to => Type ([item] -> from) to -> [item] -> Type from to
(||+) (xs,x_) y = case plateListDiff y of
(ys,y_) -> (Two xs ys, \(Two xs ys) -> x_ xs (y_ ys))
where
plateListDiff [] = plate []
plateListDiff (x:xs) = plate (:) |+ x ||+ xs
-- | Used for 'PlayAll' definitions where both types are the same.
plateSelf :: to -> Type to to
plateSelf x = (One x, \(One x) -> x)
uniplate-1.6.11/Data/Generics/PlateData.hs 0000644 0000000 0000000 00000011433 12202721612 016407 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, ExistentialQuantification, Rank2Types, CPP #-}
{- |
/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
{-# DEPRECATED "Use Data.Generics.Uniplate.Data instead" #-}
(
module Data.Generics.Biplate
) where
import Data.Generics.Biplate
import Data.Generics.Uniplate.Internal.Utils
import Data.Generics
#if !(__GLASGOW_HASKELL__ < 606 || __GLASGOW_HASKELL__ >= 702)
import Data.List
import qualified Data.IntSet as IntSet
import Data.Ratio
#endif
-- | 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)
| Follow -- go forward, you will find something
| Miss -- you failed to sink my battleship!
containsMatch :: (Data start, Typeable start, Data find, Typeable find) =>
start -> find ->
Box find
#if __GLASGOW_HASKELL__ < 606 || __GLASGOW_HASKELL__ >= 702
-- 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
containsMatch start find = Box query
where
query a = case cast a of
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 (unsafeCoerce 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
answer :: Box a
answer = containsMatch (undefined :: a) (undefined :: a)
instance (Data a, Data b, Uniplate b, Typeable a, Typeable b) => Biplate a b where
biplate = collect_generate_self (fromBox answer)
where
answer :: Box b
answer = containsMatch (undefined :: a) (undefined :: b)
newtype C x a = C {fromC :: CC x a}
type CC x a = (Str x, Str x -> a)
collect_generate_self :: (Data on, Data with, Typeable on, Typeable with) =>
(forall a . Typeable a => a -> Answer with) -> on -> CC with on
collect_generate_self oracle x = res
where
res = case oracle x of
Hit y -> (One y, \(One x) -> unsafeCoerce x)
Follow -> collect_generate oracle x
Miss -> (Zero, \_ -> x)
collect_generate :: (Data on, Data with, Typeable on, Typeable with) =>
(forall a . Typeable a => a -> Answer with) -> on -> CC with on
collect_generate oracle item = fromC $ gfoldl combine create item
where
-- forall a b . Data a => C with (a -> b) -> a -> C with b
combine (C (c,g)) x = case collect_generate_self oracle x of
(c2, g2) -> C (Two c c2, \(Two c' c2') -> g c' (g2 c2'))
-- forall g . g -> C with g
create x = C (Zero, \_ -> x)
uniplate-1.6.11/Data/Generics/Compos.hs 0000644 0000000 0000000 00000003214 12202721612 016006 0 ustar 00 0000000 0000000 {-|
Compos compatibility layer. This module serves as a drop-in
replacement in some situations for some of the Compos operations.
Only the single-type traversals are supported, on normal
algebraic data types. Users should also import either "Data.Generics.Uniplate.Data"
or "Data.Generics.Uniplate.Direct".
Compos is described in the paper: \"A Pattern for Almost Compositional Functions\"
by Bjorn Bringert and Aarne Ranta.
*
*
-}
module Data.Generics.Compos where
import Control.Monad
import Data.Monoid
import Data.Generics.Uniplate.Operations
-- | If you want to keep an existing type class
class Uniplate a => Compos a where
-- | @composOp == 'descend'@
composOp :: Uniplate a => (a -> a) -> a -> a
composOp = descend
-- | @composOpM == 'descendM'@
composOpM :: (Uniplate a, Monad m) => (a -> m a) -> a -> m a
composOpM = descendM
-- | @composOpM_ == 'composOpFold' (return ()) (>>)@
composOpM_ :: (Uniplate a, Monad m) => (a -> m ()) -> a -> m ()
composOpM_ = composOpFold (return ()) (>>)
-- | @composOpMonoid = 'composOpFold' mempty mappend@
composOpMonoid :: (Uniplate a, Monoid m) => (a -> m) -> a -> m
composOpMonoid = composOpFold mempty mappend
-- | @composOpMPlus = 'composOpFold' mzero mplus@
composOpMPlus :: (Uniplate a, MonadPlus m) => (a -> m b) -> a -> m b
composOpMPlus = composOpFold mzero mplus
-- | Probably replace with 'universe', perhaps 'para'
composOpFold :: Uniplate a => b -> (b -> b -> b) -> (a -> b) -> a -> b
composOpFold zero combine f = foldr combine zero . map f . children
uniplate-1.6.11/Data/Generics/Biplate.hs 0000644 0000000 0000000 00000005003 12202721612 016124 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses #-}
{- |
/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
{- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -}
(
module Data.Generics.UniplateStrOn,
module Data.Generics.Biplate
) where
import Data.Generics.UniplateStrOn
-- * The Class
-- | Children are defined as the top-most items of type to
-- /starting at the root/.
class Uniplate to => Biplate from to where
biplate :: BiplateType from to
-- | Compatibility method, for direct users of the 'biplate' function
biplateList :: Biplate from to => from -> ([to], [to] -> from)
biplateList x = (c, b . d)
where
(a,b) = biplate x
(c,d) = strStructure a
-- * The Operations
-- ** Queries
universeBi :: Biplate from to => from -> [to]
universeBi = universeOn biplate
childrenBi :: Biplate from to => from -> [to]
childrenBi = childrenOn biplate
-- ** Transformations
transformBi :: Biplate from to => (to -> to) -> from -> from
transformBi = transformOn biplate
transformBiM :: (Monad m, Biplate from to) => (to -> m to) -> from -> m from
transformBiM = transformOnM biplate
rewriteBi :: Biplate from to => (to -> Maybe to) -> from -> from
rewriteBi = rewriteOn biplate
rewriteBiM :: (Monad m, Biplate from to) => (to -> m (Maybe to)) -> from -> m from
rewriteBiM = rewriteOnM biplate
descendBi :: Biplate from to => (to -> to) -> from -> from
descendBi = descendOn biplate
descendBiM :: (Monad m, Biplate from to) => (to -> m to) -> from -> m from
descendBiM = descendOnM biplate
-- ** Others
contextsBi:: Biplate from to => from -> [(to, to -> from)]
contextsBi = contextsOn biplate
holesBi:: Biplate from to => from -> [(to, to -> from)]
holesBi = holesOn biplate
uniplate-1.6.11/Data/Generics/Uniplate/ 0000755 0000000 0000000 00000000000 12202721612 015773 5 ustar 00 0000000 0000000 uniplate-1.6.11/Data/Generics/Uniplate/Zipper.hs 0000644 0000000 0000000 00000011306 12202721612 017601 0 ustar 00 0000000 0000000 {-|
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
uniplate-1.6.11/Data/Generics/Uniplate/Typeable.hs 0000644 0000000 0000000 00000012337 12202721612 020102 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
{- |
/RECOMMENDATION:/ Use "Data.Generics.Uniplate.Data" instead - it usually performs
faster (sometimes significantly so) and requires no special instance declarations.
This module supplies a method for writing 'Uniplate' / 'Biplate' instances. One
instance declaration is required for each data type you wish to work with. The
instances can be generated using Derive: .
To take an example:
> data Expr = Var Int | Neg Expr | Add Expr Expr
> deriving Typeable
>
> instance (Typeable a, Uniplate a) => PlateAll Expr a where
> plateAll (Var x ) = plate Var |+ x
> plateAll (Neg x ) = plate Neg |+ x
> plateAll (Add x y) = plate Add |+ x |+ y
-}
module Data.Generics.Uniplate.Typeable(
module Data.Generics.Uniplate.Operations,
module Data.Typeable,
-- * The Class
PlateAll(..),
-- * The Combinators
plate, (|+), (|-), plateProject
) where
import Control.Arrow
import Data.Generics.Uniplate.Operations
import Data.Generics.Uniplate.Internal.Utils
import Data.Generics.Str
import Data.Typeable
import Data.Ratio
instance (Typeable a, Typeable b, Uniplate b, PlateAll a b) => Biplate a b where
biplate = plateMore
instance PlateAll a a => Uniplate a where
uniplate = plateAll
type Type from to = (Str to, Str to -> from)
plateMore :: (Typeable from, Typeable to, PlateAll from to) => from -> Type from to
plateMore x = res
where
res = case asTypeOf (cast x) (Just $ strType $ fst res) of
Nothing -> plateAll x
Just y -> (One y, \(One y) -> unsafeCoerce y)
-- | This class should be defined for each data type of interest.
class PlateAll from to where
-- | This method should be defined using 'plate' and '|+', '|-'.
plateAll :: from -> Type from to
-- | The main combinator used to start the chain.
plate :: from -> Type from to
plate x = (Zero, \_ -> x)
-- | The field to the right may contain the target.
(|+) :: (Typeable item, Typeable to, PlateAll item to) => Type (item -> from) to -> item -> Type from to
(|+) (xs,x_) y = case plateMore y of
(ys,y_) -> (Two xs ys,\(Two xs ys) -> x_ xs (y_ ys))
-- | The field to the right /does not/ contain the target.
-- This can be used as either an optimisation, or more commonly for excluding
-- primitives such as Int.
(|-) :: Type (item -> from) to -> item -> Type from to
(|-) (xs,x_) y = (xs,\xs -> x_ xs y)
-- | Write an instance in terms of a projection/injection pair. Usually used to define instances
-- for abstract containers such as Map:
--
-- > instance (Ord a, Typeable a, PlateAll a c, Typeable b, PlateAll b c,
-- > Typeable c, PlateAll c c) => PlateAll (Map.Map a b) c where
-- > plateAll = plateProject Map.toList Map.fromList
plateProject :: (Typeable item, Typeable to, PlateAll item to) => (from -> item) -> (item -> from) -> from -> Type from to
plateProject into outof = second (outof . ) . plateAll . into
-- * Instances
-- ** Primitive Types
instance PlateAll Int to where plateAll x = plate x
instance PlateAll Bool to where plateAll x = plate x
instance PlateAll Char to where plateAll x = plate x
instance PlateAll Integer to where plateAll x = plate x
instance PlateAll Double to where plateAll x = plate x
instance PlateAll Float to where plateAll x = plate x
instance PlateAll () to where plateAll x = plate x
-- ** Container Types
instance (PlateAll from to, Typeable from, Typeable to, Uniplate to) => PlateAll [from] to where
plateAll [] = plate []
plateAll (x:xs) = plate (:) |+ x |+ xs
instance (PlateAll from to, Typeable from, Typeable to, Uniplate to) => PlateAll (Maybe from) to where
plateAll Nothing = plate Nothing
plateAll (Just x) = plate Just |+ x
instance (PlateAll a to, Typeable a, PlateAll b to, Typeable b, Typeable to, Uniplate to) =>
PlateAll (Either a b) to where
plateAll (Left x) = plate Left |+ x
plateAll (Right x) = plate Right |+ x
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,Typeable to, Uniplate to) =>
PlateAll (a,b) to where
plateAll (a,b) = plate (,) |+ a |+ b
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,PlateAll c to, Typeable c
,Typeable to, Uniplate to) =>
PlateAll (a,b,c) to where
plateAll (a,b,c) = plate (,,) |+ a |+ b |+ c
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,PlateAll c to, Typeable c
,PlateAll d to, Typeable d
,Typeable to, Uniplate to) =>
PlateAll (a,b,c,d) to where
plateAll (a,b,c,d) = plate (,,,) |+ a |+ b |+ c |+ d
instance (PlateAll a to, Typeable a
,PlateAll b to, Typeable b
,PlateAll c to, Typeable c
,PlateAll d to, Typeable d
,PlateAll e to, Typeable e
,Typeable to, Uniplate to) =>
PlateAll (a,b,c,d,e) to where
plateAll (a,b,c,d,e) = plate (,,,,) |+ a |+ b |+ c |+ d |+ e
instance (Integral a, PlateAll a to, Typeable a, Typeable to, Uniplate to) => PlateAll (Ratio a) to where
plateAll = plateProject (\x -> (numerator x, denominator x)) (uncurry (%))
uniplate-1.6.11/Data/Generics/Uniplate/Operations.hs 0000644 0000000 0000000 00000001161 12202721612 020451 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, MultiParamTypeClasses #-}
{- |
Definitions of 'Uniplate' and 'Biplate' classes, along with all the standard operations.
Import this module directly only if you are defining new Uniplate operations, otherwise
import one of "Data.Generics.Uniplate.Direct", "Data.Generics.Uniplate.Typeable" or
"Data.Generics.Uniplate.Data".
Most functions have an example of a possible use for the function.
To illustate, I have used the @Expr@ type as below:
> data Expr = Val Int
> | Neg Expr
> | Add Expr Expr
-}
module Data.Generics.Uniplate.Operations where
#include "Internal/OperationsInc.hs"
uniplate-1.6.11/Data/Generics/Uniplate/Direct.hs 0000644 0000000 0000000 00000013664 12202721612 017553 0 ustar 00 0000000 0000000 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
{- |
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: .
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
>
> instance Uniplate Expr where
> uniplate (Var x ) = plate Var |- x
> uniplate (Pos x y) = plate Pos |* x |- y
> uniplate (Neg x ) = plate Neg |* x
> uniplate (Add x y) = plate Add |* x |* y
>
> instance Biplate Expr Expr where
> biplate = plateSelf
>
> instance Uniplate Stmt where
> uniplate (Seq x ) = plate Seq ||* x
> uniplate (Sel x ) = plate Sel ||+ x
> uniplate (Let x y) = plate Let |- x |- y
>
> instance Biplate Stmt Stmt where
> biplate = plateSelf
>
> instance Biplate Stmt Expr where
> 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
plate, plateSelf,
(|+), (|-), (|*), (||+), (||*),
plateProject
) where
import Control.Arrow
import Data.Generics.Uniplate.Operations
import Data.Generics.Str
import Data.Ratio
type Type from to = (Str to, Str to -> from)
-- | The main combinator used to start the chain.
--
-- The following rule can be used for optimisation:
--
-- > plate Ctor |- x == plate (Ctor x)
{-# 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[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[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[1] (|-) #-}
(|-) :: Type (item -> from) to -> item -> Type from to
(|-) (xs,x_) y = (xs,\xs -> x_ xs y)
-- | The field to the right is a list of the type of the target
{-# INLINE (||*) #-}
(||*) :: Type ([to] -> from) to -> [to] -> Type from to
(||*) (xs,x_) y = (Two xs (listStr y), \(Two xs ys) -> x_ xs (strList ys))
-- | The field to the right is a list of types which may contain the target
(||+) :: Biplate item to => Type ([item] -> from) to -> [item] -> Type from to
(||+) (xs,x_) [] = (xs, \xs -> x_ xs []) -- can eliminate a Two _ Zero in the base case
(||+) (xs,x_) (y:ys) = case plate (:) |+ y ||+ ys of
(ys,y_) -> (Two xs ys, \(Two xs ys) -> x_ xs (y_ ys))
-- | Used for 'Biplate' definitions where both types are the same.
plateSelf :: to -> Type to to
plateSelf x = (One x, \(One x) -> x)
-- | 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
plateProject :: Biplate item to => (from -> item) -> (item -> from) -> from -> Type from to
plateProject into outof = second (outof . ) . biplate . into
instance Uniplate Int where uniplate x = plate x
instance Uniplate Bool where uniplate x = plate x
instance Uniplate Char where uniplate x = plate x
instance Uniplate Integer where uniplate x = plate x
instance Uniplate Double where uniplate x = plate x
instance Uniplate Float where uniplate x = plate x
instance Uniplate () where uniplate x = plate x
instance Uniplate [Char] where
uniplate (x:xs) = plate (x:) |* xs
uniplate x = plate x
instance Biplate [Char] Char where
biplate (x:xs) = plate (:) |* x ||* xs
biplate x = plate x
instance Biplate [Char] [Char] where
biplate = plateSelf
instance Uniplate (Ratio Integer) where
uniplate = plate
instance Biplate (Ratio Integer) (Ratio Integer) where
biplate = plateSelf
instance Biplate (Ratio Integer) Integer where
biplate x = (Two (One (numerator x)) (One (denominator x)), \(Two (One n) (One d)) -> n % d)
uniplate-1.6.11/Data/Generics/Uniplate/DataOnly.hs 0000644 0000000 0000000 00000001355 12202721612 020046 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, Rank2Types, CPP,
MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
{- |
This module functions identically to "Data.Generics.Uniplate.Data", but instead of
using the standard 'Uniplate' / 'Biplate' classes defined in
"Data.Generics.Uniplate.Operations" it uses a local copy.
Only use this module if you are using both @Data@ and @Direct@ instances in
the same project and they are conflicting.
-}
module Data.Generics.Uniplate.DataOnly(
module Data.Generics.Uniplate.Internal.DataOnlyOperations,
transformBis, Transformer, transformer
) where
import Data.Generics.Uniplate.Internal.DataOnlyOperations
#include "Internal/DataInc.hs"
uniplate-1.6.11/Data/Generics/Uniplate/Data.hs 0000644 0000000 0000000 00000003517 12202721612 017206 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, Rank2Types, CPP,
MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
{- |
This module defines 'Uniplate' / 'Biplate' instances for every type with a
'Data' instance. Using GHC, Data can be derived automatically with:
> data Expr = Var Int | Neg Expr | Add Expr Expr
> deriving (Data,Typeable)
All the Uniplate operations defined in "Data.Generics.Uniplate.Operations"
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,
transformBis, Transformer, transformer
) where
import Data.Generics.Uniplate.Operations
#include "Internal/DataInc.hs"
uniplate-1.6.11/Data/Generics/Uniplate/Internal/ 0000755 0000000 0000000 00000000000 12202721612 017547 5 ustar 00 0000000 0000000 uniplate-1.6.11/Data/Generics/Uniplate/Internal/Utils.hs 0000644 0000000 0000000 00000003000 12202721612 021174 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, 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, SPEC(SPEC)
) where
#if __GLASGOW_HASKELL__ >= 702
import System.IO.Unsafe(unsafePerformIO)
#else
import Foreign(unsafePerformIO)
#endif
import Unsafe.Coerce(unsafeCoerce)
#ifdef __GLASGOW_HASKELL__
import GHC.Exts(build, realWorld#)
#if __GLASGOW_HASKELL__ < 612
import GHC.IOBase(IO(IO))
#else
import GHC.IO(IO(IO))
#endif
#endif
#if __GLASGOW_HASKELL__ >= 701
import GHC.Exts(SpecConstrAnnotation(..))
{-# ANN type SPEC ForceSpecConstr #-}
#endif
{-# 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 #-}
-- | Perform concatentation of continuations
concatCont :: [a -> a] -> a -> a
concatCont xs rest = foldr ($) rest xs
-- | Constructor specialisation on newer GHC
data SPEC = SPEC | SPEC2
uniplate-1.6.11/Data/Generics/Uniplate/Internal/OperationsInc.hs 0000644 0000000 0000000 00000020573 12202721612 022667 0 ustar 00 0000000 0000000 import Control.Monad
import Data.Generics.Str
import Data.Generics.Uniplate.Internal.Utils
-- * The Classes
-- | 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
-- of the same type, and a function to replace them.
--
-- Given @uniplate x = (cs, gen)@
--
-- @cs@ should be a @Str on@, constructed of @Zero@, @One@ and @Two@,
-- containing all @x@'s direct children of the same type as @x@. @gen@
-- should take a @Str on@ with exactly the same structure as @cs@,
-- and generate a new element with the children replaced.
--
-- Example instance:
--
-- > instance Uniplate Expr where
-- > uniplate (Val i ) = (Zero , \Zero -> Val i )
-- > uniplate (Neg a ) = (One a , \(One a) -> Neg a )
-- > uniplate (Add a b) = (Two (One a) (One b), \(Two (One a) (One b)) -> Add a b)
uniplate :: on -> (Str on, Str on -> on)
-- | 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. 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 = case uniplate x of
(current, generate) -> generate $ strMap f current
-- | Monadic variant of 'descend'
{-# INLINE descendM #-}
descendM :: Monad m => (on -> m on) -> on -> m on
descendM f x = case uniplate x of
(current, generate) -> liftM generate $ strMapM f current
-- | Children are defined as the top-most items of type to
-- /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.
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 = case biplate x of
(current, generate) -> generate $ strMap f current
{-# INLINE descendBiM #-}
descendBiM :: Monad m => (to -> m to) -> from -> m from
descendBiM f x = case biplate x of
(current, generate) -> liftM generate $ strMapM f current
-- * Single Type Operations
-- ** Queries
-- | Get all the children of a node, including itself and all children.
--
-- > universe (Add (Val 1) (Neg (Val 2))) =
-- > [Add (Val 1) (Neg (Val 2)), Val 1, Neg (Val 2), Val 2]
--
-- This method is often combined with a list comprehension, for example:
--
-- > vals x = [i | Val i <- universe x]
{-# INLINE universe #-}
universe :: Uniplate on => on -> [on]
universe x = builder f
where
f cons nil = g cons nil (One x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` g cons nil (fst $ uniplate x) res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- | Get the direct children of a node. Usually using 'universe' is more appropriate.
children :: Uniplate on => on -> [on]
children x = builder f
where
f cons nil = g cons nil (fst $ uniplate x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- ** Transformations
-- | Transform every element in the tree, in a bottom-up manner.
--
-- For example, replacing negative literals with literals:
--
-- > negLits = transform f
-- > where f (Neg (Lit i)) = Lit (negate i)
-- > f x = x
transform :: Uniplate on => (on -> on) -> on -> on
transform f = g
where g = f . descend g
-- | Monadic variant of 'transform'
transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on
transformM f = g
where g x = f =<< descendM g x
-- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot
-- be applied anywhere in the result:
--
-- > propRewrite r x = all (isNothing . r) (universe (rewrite r x))
--
-- Usually 'transform' is more appropriate, but 'rewrite' can give better
-- compositionality. Given two single transformations @f@ and @g@, you can
-- construct @f `mplus` g@ which performs both rewrites until a fixed point.
rewrite :: Uniplate on => (on -> Maybe on) -> on -> on
rewrite f = transform g
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
rewriteM f = transformM g
where g x = f x >>= maybe (return x) (rewriteM f)
-- ** Others
-- | Return all the contexts and holes.
--
-- > 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
f xs = [ (y, ctx . context)
| (child, ctx) <- xs
, (y, context) <- contexts child]
-- | The one depth version of 'contexts'
--
-- > 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 _ = []
f (One i) generate = [(i, generate . One)]
f (Two l r) gen = f l (gen . (\i -> Two i r))
++ f r (gen . (\i -> Two l i))
-- | Perform a fold-like computation on each value,
-- technically a paramorphism
para :: Uniplate on => (on -> [r] -> r) -> on -> r
para op x = op x $ map (para op) $ children x
-- * Multiple Type Operations
-- ** Queries
{-# INLINE universeBi #-}
universeBi :: Biplate from to => from -> [to]
universeBi x = builder f
where
f cons nil = g cons nil (fst $ biplate x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` g cons nil (fst $ uniplate x) res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- | Return the children of a type. If @to == from@ then it returns the
-- original element (in contrast to 'children')
childrenBi :: Biplate from to => from -> [to]
childrenBi x = builder f
where
f cons nil = g cons nil (fst $ biplate x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- ** Transformations
{-# INLINE transformBi #-}
transformBi :: Biplate from to => (to -> to) -> from -> from
transformBi f x = case biplate x of
(current, generate) -> generate $ strMap (transform f) current
{-# INLINE transformBiM #-}
transformBiM :: (Monad m, Biplate from to) => (to -> m to) -> from -> m from
transformBiM f x = case biplate x of
(current, generate) -> liftM generate $ strMapM (transformM f) current
rewriteBi :: Biplate from to => (to -> Maybe to) -> from -> from
rewriteBi f x = case biplate x of
(current, generate) -> generate $ strMap (rewrite f) current
rewriteBiM :: (Monad m, Biplate from to) => (to -> m (Maybe to)) -> from -> m from
rewriteBiM f x = case biplate x of
(current, generate) -> liftM generate $ strMapM (rewriteM f) current
-- ** Others
contextsBi:: Biplate from to => from -> [(to, to -> from)]
contextsBi = f . holesBi
where
f xs = [ (y, ctx . context)
| (child, ctx) <- xs
, (y, context) <- contexts child]
holesBi:: Biplate from to => from -> [(to, to -> from)]
holesBi = uncurry f . biplate
where f Zero _ = []
f (One i) generate = [(i, generate . One)]
f (Two l r) gen = f l (gen . (\i -> Two i r))
++ f r (gen . (\i -> Two l i))
uniplate-1.6.11/Data/Generics/Uniplate/Internal/DataOnlyOperations.hs 0000644 0000000 0000000 00000000212 12202721612 023655 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, MultiParamTypeClasses #-}
module Data.Generics.Uniplate.Internal.DataOnlyOperations where
#include "OperationsInc.hs"
uniplate-1.6.11/Data/Generics/Uniplate/Internal/DataInc.hs 0000644 0000000 0000000 00000001512 12202721612 021405 0 ustar 00 0000000 0000000 import Data.Generics.Uniplate.Internal.Data
import Data.Data
instance Data a => Uniplate a where
uniplate = uniplateData $ fromOracle answer
where answer = hitTest (undefined :: a) (undefined :: a)
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)
descendBi = descendBiData $ fromOracle answer
where answer = hitTest (undefined :: a) (undefined :: b)
descendBiM = descendBiDataM $ fromOracle answer
where answer = hitTest (undefined :: a) (undefined :: b)
uniplate-1.6.11/Data/Generics/Uniplate/Internal/Data.hs 0000644 0000000 0000000 00000034740 12202721612 020764 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification, ScopedTypeVariables #-}
{- |
Internal module, do not import or use.
-}
module Data.Generics.Uniplate.Internal.Data where
import Data.Generics.Str
import Data.Generics.Uniplate.Internal.Utils
import Data.Data
import Data.Generics
import Data.Maybe
import Data.List
import Data.IORef
import Control.Exception
import Control.Monad
import System.Environment(getEnv)
import qualified Data.IntMap as IntMap; import Data.IntMap(IntMap)
#if __GLASGOW_HASKELL__ < 606
---------------------------------------------------------------------
-- GHC 6.4 and below
import qualified Data.Set as Set
import qualified Data.Map as Map
type TypeKey = TypeRep
type TypeSet = Set.Set TypeKey
type TypeMap = Map.Map TypeKey
typeKey :: Typeable a => a -> TypeKey
typeKey = typeOf
#elif __GLASGOW_HASKELL__ < 702
---------------------------------------------------------------------
-- GHC 6.6 to 7.0 (has typeRepKey)
import qualified Data.IntSet as Set
import qualified Data.IntMap as Map
type TypeKey = Int
type TypeSet = Set.IntSet
type TypeMap = Map.IntMap
typeKey :: Typeable a => a -> TypeKey
typeKey x = inlinePerformIO $ typeRepKey $ typeOf x
#else
---------------------------------------------------------------------
-- GHC 7.2 and above (using fingerprint)
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
type TypeSet = Set.HashSet TypeKey
type TypeMap = Map.HashMap TypeKey
type TypeKey = TypeRep
typeKey :: Typeable a => a -> TypeKey
typeKey = typeOf
#endif
#if __GLASGOW_HASKELL__ < 702
---------------------------------------------------------------------
-- GHC 7.0 and below (using containers API)
(!) = (Map.!)
map_findWithDefault = Map.findWithDefault
map_fromAscList = Map.fromAscList
map_keysSet = Map.keysSet
map_member = Map.member
set_partition = Set.partition
set_toAscList = Set.toAscList
set_unions = Set.unions
#else
---------------------------------------------------------------------
-- GHC 7.2 and above (using unordered-containers API)
(!) 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
#endif
{-# 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
---------------------------------------------------------------------
-- 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
hitTest from to =
let kto = typeKey to
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
else if test kon then Follow
else Miss
---------------------------------------------------------------------
-- CACHE
-- Store and compute the Follower and HitMap
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 Map.empty
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.try (return $! insertHitMap from hit)
(hit,fol) <- return $ case res of
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
---------------------------------------------------------------------
-- 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)
intLookup2 :: Int -> Int -> IntMap2 a -> Maybe a
intLookup2 x y mp = IntMap.lookup x mp >>= IntMap.lookup y
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
---------------------------------------------------------------------
-- FOLLOWER
-- Function to test if you should follow
type Follower = TypeKey -> Bool
-- HitMap must have addHitMap on the key
follower :: TypeKey -> TypeKey -> HitMap -> Follower
follower from to mp
| 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) = 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
-- | 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
-- NOTE: This function is partial, but all exceptions are caught later on
sybChildren :: Data a => a -> [DataBox]
sybChildren x
| isAlgType dtyp = concatMap f ctrs
| 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)
ctrs = dataTypeConstrs dtyp
dtyp = dataTypeOf x
---------------------------------------------------------------------
-- HITMAP
-- What is the transitive closure of a type key
type HitMap = TypeMap TypeSet
emptyHitMap :: HitMap
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) `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 Map.empty
where
f (DataBox key val) 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
fs (x:xs) mp = fs xs (f x mp)
-- update every one to be the transitive closure
trans :: HitMap -> HitMap
trans mp = Map.map f mp
where
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
fixEq f x = if x == x2 then x2 else fixEq f x2
where x2 = f x
---------------------------------------------------------------------
-- INSTANCE FUNCTIONS
newtype C x a = C {fromC :: CC x a}
type CC x a = (Str x, Str x -> a)
biplateData :: (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> on -> CC with on
biplateData oracle x = case oracle x of
Hit y -> (One y, \(One x) -> unsafeCoerce x)
Follow -> uniplateData oracle x
Miss -> (Zero, \_ -> x)
uniplateData :: forall on with . (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> on -> CC with on
uniplateData oracle item = fromC $ gfoldl combine create item
where
combine :: Data a => C with (a -> b) -> a -> C with b
combine (C (c,g)) x = case biplateData oracle x of
(c2, g2) -> C (Two c c2, \(Two c' c2') -> g c' (g2 c2'))
create :: g -> C with g
create x = C (Zero, \_ -> x)
descendData :: Data on => (forall a . Typeable a => a -> Answer on) -> (on -> on) -> on -> on
descendData oracle op = gmapT (descendBiData oracle op)
descendBiData :: (Data on, Data with) => (forall a . Typeable a => a -> Answer with) -> (with -> with) -> on -> on
descendBiData oracle op x = case oracle x of
Hit y -> unsafeCoerce $ op y
Follow -> gmapT (descendBiData oracle op) x
Miss -> x
descendDataM :: (Data on, Monad m) => (forall a . Typeable a => a -> Answer on) -> (on -> m on) -> on -> m on
descendDataM oracle op = gmapM (descendBiDataM oracle op)
descendBiDataM :: (Data on, Data with, Monad 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 -> gmapM (descendBiDataM oracle op) x
Miss -> return 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)
uniplate-1.6.11/Data/Generics/Uniplate/Data/ 0000755 0000000 0000000 00000000000 12202721612 016644 5 ustar 00 0000000 0000000 uniplate-1.6.11/Data/Generics/Uniplate/Data/Instances.hs 0000644 0000000 0000000 00000027513 12202721612 021137 0 ustar 00 0000000 0000000 {-# 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)