alloy (empty) → 1.0.0

raw patch · 22 files changed

+2049/−0 lines, 22 filesdep +basedep +containersdep +mtlsetup-changed

Dependencies added: base, containers, mtl, syb

Files

• Data/Generics/Alloy.hs +51/−0
• Data/Generics/Alloy/Effect.hs +122/−0
• Data/Generics/Alloy/GenInstances.hs +700/−0
• Data/Generics/Alloy/Pure.hs +91/−0
• Data/Generics/Alloy/Route.hs +199/−0
• Data/Generics/Alloy/Schemes.hs +207/−0
• LICENSE +27/−0
• Setup.lhs +5/−0
• alloy.cabal +68/−0
• tutorial/CompanyDatatypes.lhs +46/−0
• tutorial/Constraints.lhs +42/−0
• tutorial/Effects.lhs +38/−0
• tutorial/EffectsSelective.lhs +46/−0
• tutorial/GenTypes.lhs +30/−0
• tutorial/GenTypesMapSet.lhs +26/−0
• tutorial/MapSet.lhs +30/−0
• tutorial/MapSetExample.lhs +54/−0
• tutorial/Paradise.lhs +22/−0
• tutorial/Query.lhs +31/−0
• tutorial/Routes.lhs +45/−0
• tutorial/Selective.lhs +57/−0
• tutorial/tutorial.tex +112/−0

@@ -0,0 +1,51 @@+-- Alloy.+-- Copyright (c) 2008-2009, University of Kent.+-- 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 the University of Kent nor the names of its+--    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.++-- | Alloy is a generic programming system for automatically traversing data+-- structures, operating on specific types within that structure.+--+-- To use the Alloy module, you can either use the helper functions from the+-- "Data.Generics.Alloy.Schemes" module or the lower-level functions from+-- "Data.Generics.Alloy.Pure" and "Data.Generics.Alloy.Effect".  The tutorial+-- (<http://twistedsquare.com/Alloy-Tutorial.pdf>) provides examples of each+-- of these.  The tutorial also explains how to use the "Data.Generics.Alloy.GenInstances"+-- module to generate the instances that Alloy needs for your data.+module Data.Generics.Alloy (+  module Data.Generics.Alloy.Pure,+  module Data.Generics.Alloy.Effect,+  module Data.Generics.Alloy.Route,+  module Data.Generics.Alloy.Schemes,+  ) where++import Data.Generics.Alloy.Pure+import Data.Generics.Alloy.Effect+import Data.Generics.Alloy.Route+import Data.Generics.Alloy.Schemes++

@@ -0,0 +1,122 @@+-- Alloy.+-- Copyright (c) 2008-2009, University of Kent.+-- 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 the University of Kent nor the names of its+--    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.++-- | The module containing the AlloyA type-class for working with effectful functions+-- (of the type @a -> m a@).  This module is an analogue to "Data.Generics.Alloy.Pure"+-- that supports functions that result in a monadic or applicative functor type.+--+-- All the functions in this module have versions for 'Applicative' and for+-- 'Monad'.  They have the same behaviour, and technically only the+-- 'Applicative' version is necessary, but since not all monads have+-- 'Applicative' instances, the 'Monad' versions are provided for convenience.+module Data.Generics.Alloy.Effect where++import Control.Applicative++-- | The Alloy type-class for effectful functions, to be used with sets of+-- operations constructed from 'BaseOpA' and ':-*'.  You are unlikely to need to+-- use 'transform' directly; instead use 'makeRecurseA'\/'makeRecurseM' and 'makeDescendA'\/'makeDescendM'.+--+-- The first parameter to the type-class is the type currently being operated+-- on, the second parameter is the set of operations to perform directly on+-- the type, and the third parameter is the set of operations to perform on+-- its children (if none of the second parameter operations can be applied).+class AlloyA t o o' where+  transformM :: Monad m => o m -> o' m -> t -> m t+  transformA :: Applicative f => o f -> o' f -> t -> f t++-- | A type representing a monadic/applicative functor modifier function that+-- applies the given ops (opT) in the given monad/functor (f) directly to the+-- given type (t).+type RecurseA f opT = forall t. AlloyA t opT BaseOpA => t -> f t++-- | Given a set of operations (as described in the 'AlloyA' type-class),+-- makes a recursive modifier function that applies the operations directly to+-- the given type, and then to its children, until it has been applied to all+-- the largest instances of that type.+makeRecurseA :: Applicative f => opT f -> RecurseA f opT+makeRecurseA ops = transformA ops baseOpA++-- | Useful equivalent of 'makeRecurseA'.+makeRecurseM :: Monad m => opT m -> RecurseA m opT+makeRecurseM ops = transformM ops baseOpA++-- | A type representing a monadic/applicative functor modifier function that+-- applies the given ops (opT) in the given monad/functor (f) to the children of the+-- given type (t).+type DescendA f opT = forall t. AlloyA t BaseOpA opT => t -> f t++-- | Given a set of operations, makes a descent modifier function that applies+-- the operation to the type's children, and further down, until it has been applied+-- to all the largest instances of that type.+makeDescendA :: Applicative f => opT f -> DescendA f opT+makeDescendA ops = transformA baseOpA ops++-- | Useful equivalent of 'makeDescendA'.+makeDescendM :: Monad m => opT m -> DescendA m opT+makeDescendM ops = transformM baseOpA ops++-- | The terminator for effectful opsets.  Note that all effectful opsets are the+-- same, and both can be used with the applicative functions or monad functions+-- in this module.  Whereas there is, for example, both 'makeRecurseA' and 'makeRecurseM',+-- there is only one terminator for the opsets, 'BaseOpA', which should be used+-- regardless of whether you use 'makeRecurseA' or 'makeRecurseM'.+data BaseOpA m = BaseOpA++-- | The function to give you an item of type 'BaseOpA'.+baseOpA :: BaseOpA m+baseOpA = BaseOpA++-- | The type that extends an opset (opT) in the given+-- monad/applicative-functor (m) to be applied to the given type (t).  This is+-- for use with the 'AlloyA' class.  A set of operations that operates+-- on @Foo@, @Bar@ and @Baz@ in the IO monad can be constructed so:+--+-- > ops :: (Foo :-* Bar :-* Baz :-* BaseOpA) IO+-- > ops = doFoo :-* doBar :-* doBaz :-* baseOpA+-- >+-- > doFoo :: Foo -> IO Foo+-- > doBar :: Bar -> IO Bar+-- > doBaz :: Baz -> IO Baz+--+-- The monad/functor parameter needs to be given when declaring an actual opset,+-- but must be omitted when using the opset as part of a type-class constraint+-- such as:+--+-- > f :: AlloyA a (Foo :-* Bar :-* Baz :-* BaseOpA) BaseOpA => a -> IO a+-- > f = makeRecurse ops+data (t :-* opT) m = (t -> m t) :-* (opT m)++infixr 7 :-*++-- | A handy synonym for a monadic/applicative opset with only one item, to use with 'AlloyA'.+type OneOpA t = t :-* BaseOpA++-- | A handy synonym for a monadic/applicative opset with only two items, to use with 'AlloyA'.+type TwoOpA s t = (s :-* t :-* BaseOpA)

@@ -0,0 +1,700 @@+-- Alloy.+-- Copyright (c) 2008-2009, University of Kent.+-- 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 the University of Kent nor the names of its+--    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.++-- | A module containing code to generate instances of the Alloy class for+-- you.+--+-- Generating Alloy instances by hand would be laborious, complex and error-prone.+--  This module provides instance generation, based on the Scrap Your Boilerplate ("Data.Generics")+-- generics that have built-in support in GHC.  So you should just need to add+--+-- > deriving (Data, Typeable)+--+-- after all your data-types, then use the functions in this module to generate+-- some Haskell code with instances of the Alloy classes.  The simplest functions+-- for doing this are 'writeInstances' and 'writeInstancesTo'.  The tutorial has+-- examples of using this module.+--+-- You do not even have to modify the definitions of your data-types if you are+-- using GHC 6.8.2 or later, you can simply add these lines in your module for+-- generating the instances (assuming the data-type is not hidden during import):+--+-- > deriving instance Typeable Foo+-- > deriving instance Data Foo+--+-- That technique, and in fact this module as a whole generates orphan instances.+--  This is generally advised against in Haskell, but it should not cause any problems+-- here.+--+-- The primary drawback of Alloy's approach is that it can generate a lot of+-- type-class instances (generally, the square of the number of types).  There+-- are two ways to control this explosion.  Using 'GenWithOverlapped' tends to+-- halve the number of instances, at the cost of using a GHC extension.  If+-- you need instances for more than one of 'Alloy', 'AlloyA' and+-- 'AlloyARoute', it is possible to define one based on another, and thus+-- avoid an entire set of instances altogether.  See the alloy-proxy-fd+-- package on Hackage for more details.+module Data.Generics.Alloy.GenInstances+  (writeInstances, writeInstancesTo,+   justPure, allInstances, instanceImports, instanceImportsMapSet,+   GenInstance, genInstance, genMapInstance, genSetInstance, genInstances, languageExtras,+   GenOverlappedOption(..), GenClassOption(GenOneClass), GenInstanceConfig(..)) where++import Control.Monad.State+import Data.Char+import Data.Generics+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Ord+import Data.Set (Set)+import qualified Data.Set as Set++-- | The option controlling whether the generated instances can be overlapped.+--  If you choose 'GenWithOverlapped' many less instances (around half, in our+--  experience) will be generated, but you must enable the+--  overlapping-instances flag in GHC (-XOverlappingInstances in GHC 6.8 and+--  6.10) when compiling the instances.+data GenOverlappedOption = GenWithOverlapped | GenWithoutOverlapped+  deriving (Eq, Read, Show)++-- The option controlling whether the generated instances have one class per+-- type, or just generate instances of the primary Alloy class.  Having one+-- class per type seems to compile faster on GHC, but can give less clear error messages+-- due to the name munging that goes on.++-- | For now, this option has only one setting.+data GenClassOption+  = GenClassPerType+  | GenOneClass+  | GenSlowDelegate -- ^ This is only for benchmarking purposes.  Do not use.+  deriving (Eq, Read, Show)++data GenInstanceConfig = GenInstanceConfig+  { genOverlapped :: GenOverlappedOption+  , genClass :: GenClassOption+  , genPure :: Bool+  , genEffect :: Bool+  , genRoute :: Bool+  } deriving (Eq, Read, Show)++-- | Constructs a configuration that just generates instances for the 'Alloy' type-class+-- (not 'AlloyA' or 'AlloyARoute').+justPure :: GenOverlappedOption -> GenInstanceConfig+justPure ov = GenInstanceConfig ov GenOneClass True False False++-- | Constructs instances for all the type-classes: 'Alloy', 'AlloyA' and 'AlloyARoute'.+--  This may be quite a lot, see the documentation at the top of this file.+allInstances :: GenOverlappedOption -> GenInstanceConfig+allInstances ov = GenInstanceConfig ov GenOneClass True True True++-- | A default name munging scheme for use with GenClassPerType.  Munges special+-- characters into their ASCII (or is it UTF?) code determined by ord,+-- prefixed by two underscores.+--+-- Given a string with a type name, such as "Map Int (Maybe ([String],Bool))"+-- this function must munge it into a valid suffix for a Haskell identifier,+-- i.e. using only alphanumeric characters, apostrophe and underscore.+-- Also, there may be type-level operators such as "->".  I was going to let users+-- override this, but any user that creates types like Foo__32Bar gets what they+-- deserve.+mungeName :: String -> String+mungeName = concatMap munge+  where+    munge :: Char -> String+    munge x+      | isAlphaNum x = [x]+      | otherwise = "__" ++ show (ord x)++-- | A type that represents a generator for instances of a set of types.+newtype GenInstance = GenInstance (TypeMapM ())++-- | Generates instances for all types within the given type.  Therefore you should+-- only need one or two of these calls to cover all of a complex data structure,+-- by calling this on the largest types in your structure.  The function is non-strict+-- in its argument, so the easiest way to call it is:+--+-- > genInstance (undefined :: MyType)+genInstance :: Data t => t -> GenInstance+genInstance = GenInstance . findTypesIn (const Nothing)++data Witness+  = Plain { witness :: DataBox }+    | Detailed { witness :: DataBox+               , _directlyContains :: [DataBox]+               -- First is funcSameType, second is funcNewType:+               , _processChildrenMod :: ClassType -> (FuncType -> String, FuncType -> String) -> [String]+               }++-- The Eq instance is based on the inner type.+instance Eq Witness where+  (==) wx wy = case (witness wx, witness wy) of+    (DataBox x, DataBox y) -> typeOf x == typeOf y++funcPlain :: FuncType -> String+funcPlain Func = ""+funcPlain FuncM = "return"+funcPlain FuncA = "pure"+funcPlain FuncMRoute = "return"+funcPlain FuncARoute = "pure"++funcAp :: FuncType -> String+funcAp Func = " "+funcAp FuncM = "`ap`"+funcAp FuncA = "<*>"+funcAp FuncMRoute = "`ap`"+funcAp FuncARoute = "<*>"++funcTraverse :: FuncType -> String+funcTraverse Func = "fmap"+funcTraverse FuncM = "T.mapM"+funcTraverse FuncA = "T.traverse"+funcTraverse FuncMRoute = "T.mapM"+funcTraverse FuncARoute = "T.traverse"++funcsForClass :: ClassType -> [FuncType]+funcsForClass ct = case ct of+      ClassAlloy -> [Func]+      ClassAlloyA -> [FuncA, FuncM]+      ClassAlloyARoute -> [FuncARoute, FuncMRoute]++-- | Generates an instance for the 'Data.Map.Map' type.  Map is a difficult type+-- because its instance of Data hides its implementation, so we can't actually+-- use the Data instance to work out what the children are (as we can do for other+-- algebraic data types).  So for every different Map that you want to process+-- (or that you have inside other types you want to process), you must also call+-- this function to effectively notify the generation-functions of the existence+-- of your map.  We wish there was an easier, non-hacky way but we can't see one.+genMapInstance :: forall k v. (Ord k, Data k, Data v) => k -> v -> GenInstance+genMapInstance k v+  = GenInstance $ do+       -- Must find types for contained types, in case they are not generated elsewhere.+       --  This is true for Tock, where NameDefs only exist in AST or CompState+       -- in a Map.+       findTypesIn (const Nothing) (k, v) -- This does types in k and v, and their pairing+       tk <- liftIO $ typeKey m+       modify (Map.insert tk (show $ typeOf m,+         Detailed (DataBox m) [DataBox (k, v), DataBox k, DataBox v]+         (\cl (funcSameType, funcNewType) -> concat [+           case cl of+             ClassAlloyARoute ->+               [funcSameType b ++ " _ ops (v, r) = let mns = zip (Map.toList v) (map ((r @->) . routeDataMap) [0..]) in"+               ,"  " ++ funcPlain b ++ " Map.fromList " ++ funcAp b+                 ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpARoute) mns)"+               ]+             _ -> let terminator = case cl of+                                     ClassAlloyA -> "BaseOpA"+                                     ClassAlloy -> "BaseOp" in+               [funcSameType b ++ " _ ops v = " ++ funcPlain b ++ " Map.fromList "+                 ++ funcAp b ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b+                   ++ " ops " ++ terminator ++ ") (Map.toList v))"+               ]+           | b <- funcsForClass cl])+         ))+  where+    m :: Map k v+    m = undefined++-- | Generates an instance for the 'Data.Set.Set' type.  See 'genMapInstance' for+-- an explanation.+genSetInstance :: forall a. (Ord a, Data a) => a -> GenInstance+genSetInstance x+  = GenInstance $ do+       -- Must find types for contained types, in case they are not generated elsewhere.+       findTypesIn (const Nothing) x+       tk <- liftIO $ typeKey s+       modify (Map.insert tk (show $ typeOf s,+         Detailed (DataBox s) [DataBox x]+         (\cl (funcSameType, funcNewType) -> concat [+           case cl of+             ClassAlloyARoute ->+               [funcSameType b ++ " _ ops (v, r) = let sns = zip (Set.toList v) (map ((r @->) . routeDataSet) [0..]) in"+               ,"  " ++ funcPlain b ++ " Set.fromList " ++ funcAp b+                 ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpARoute) sns)"+               ]+             _ -> let terminator = case cl of+                                     ClassAlloyA -> "BaseOpA"+                                     ClassAlloy -> "BaseOp" in+                [funcSameType b ++ " _ ops v = " ++ funcPlain b ++ " Set.fromList "+                 ++ funcAp b ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b+                   ++ " ops " ++ terminator ++ ") (Set.toList v))"]+           | b <- funcsForClass cl])++        ))+  where+    s :: Set a+    s = undefined+  +-- Explanation of Alloy's instances:+--+-- Alloy is a type-class system for automatically applying generic transformations+-- to the first instance of a specific type in a large data structure.+--+-- A set of operations is represented as a tuple list, e.g.+--+-- > (a -> m a, (b -> m b, (c -> m c, ())))+--+-- The unit type is the list terminator.+--+-- The Alloy class takes four parameters:+--+-- * The first is the type currently being processed.+--+-- * The second is the list of operations still to be checked against the current type.+--+-- * The third is the list of operations to be applied if we end up processing+-- the current type's children.+--+-- * The fourth is the monad in which it operates, which is just passed through.+--+-- There are broadly four types of instance generated by this module:+-- +-- * The "exact match" instance.  These are of the form:+-- +-- > instance Monad m => AlloyA a (a -> m a, r) ops m where+-- >   transformM (f,_) _ v = f v+-- +-- This just applies the transformation directly, as you can see, ignoring the+-- other bits and bobs.+-- +-- * The "process children" instance.  For a data type:+--+-- > data Foo = ConstrBar Bar | ConstrBazQuux Baz Quux+--+-- This is of the form:+-- +-- > instance (Monad m,+-- >           AlloyA Bar (f,ops) () m,+-- >           AlloyA Baz (f,ops) () m,+-- >           AlloyA Quux (f,ops) () m) =>+-- >         AlloyA Foo () (f, ops) m where+-- >  transformM () ops (ConstrBar a0)+-- >    = do r0 <- transformM ops () a0+-- >         return (ConstrBar r0)+-- >  transformM () ops (ConstrBazQuux a0 a1)+-- >    = do r0 <- transformM ops () a0+-- >         r1 <- transformM ops () a1+-- >         return (ConstrBazQuux r0 r1)+--+-- The reason for using (f, ops) in the type-class header is to distinguish this+-- from the empty set of operations (see lower down).  The operations that are+-- to be applied on descent (the third parameter) are passed to the sub-instances+-- as the list of operations to be checked (the second parameter), with a new blank+-- list of operations to apply on descent.  The bodies of the methods just apply+-- transformM to each child of the constructor, and pull the data-type back together+-- again.+--+--+-- * The "can contain" instance.  This is of the form:+--+-- > instance (Monad m, AlloyA t r (a -> m a, ops) m) =>+-- >         AlloyA t (a -> m a, r) ops m where+-- >  transformM (f, rest) ops v = transformM rest (f, ops) v+--+-- Here, the type being considered, t, /can/ contain the type referred to by the+-- operation, a.  So we transfer the operation from the list we're processing onto+-- the list to apply in case of direct recursion.  Then we continue processing+-- the list of operations.+--+-- * The "cannot contain" instance.  This is of the form:+--+-- > instance (Monad m, AlloyA t r ops m) =>+-- >         AlloyA t (a -> m a, r) ops m where+-- >  transformM (_, rest) ops v = transformM rest ops v+--+-- This instance is based on the logic that if we have worked out that a big type+-- (like Foo) cannot contain a certain type (say, String) then by implication,+-- neither of its children can contain Strings either.  So we omit the transformation+-- of the type (in this example String) when we directly descend into Foo, by not+-- copying the transformation onto the third parameter.+--+-- The final thing we need, is a base case+-- for when both the second and third parameters are empty.  This means there are+-- no operations left to examine, but also none available for direct recursion.+-- At this point we just return the value unchanged.++data ClassType = ClassAlloy | ClassAlloyA | ClassAlloyARoute deriving (Eq)++instance Show ClassType where+  show ClassAlloy = "Alloy"+  show ClassAlloyA = "AlloyA"+  show ClassAlloyARoute = "AlloyARoute"++data FuncType = Func | FuncA | FuncM | FuncMRoute | FuncARoute deriving (Eq)++instance Show FuncType where+  show Func = "transform"+  show FuncA = "transformA"+  show FuncM = "transformM"+  show FuncARoute = "transformARoute"+  show FuncMRoute = "transformMRoute"++-- | Instances for a particular data type (i.e. where that data type is the+-- first argument to 'Alloy').+instancesFrom :: forall t. Data t => GenOverlappedOption -> GenClassOption ->+  ClassType -> [Witness] -> t -> IO [String]+instancesFrom genOverlapped genClass genClassType boxes w+    = do (specialProcessChildren, containedTypes) <-+           case find (== Plain (DataBox w)) boxes of+             Just (Detailed _ containedTypes doChildren) ->+               -- It's a special case, use the detailed info:+               do eachContained <- sequence [findTypesIn' useBoxes c | DataBox c <- containedTypes]+                  return (Just (containedTypes, doChildren), foldl Map.union Map.empty eachContained)+             -- It's a normal case, use findTypesIn' directly:+             _ -> do ts <- findTypesIn' useBoxes w+                     return (Nothing, ts)+         containedKeys <- liftM Set.fromList+           (sequence [typeKey c | DataBox c <- map witness $ justBoxes containedTypes])+         wKey <- typeKey w+         otherInsts <- sequence [do ck <- typeKey c+                                    return (otherInst wKey containedKeys c ck)+                                | DataBox c <- map witness boxes]+         return $ baseInst specialProcessChildren ++ concat otherInsts+  where+    useBoxes k = do b <- lookup k (zip (map witness boxes) boxes)+                    case b of+                      Plain {} -> Nothing+                      Detailed _ contains _ -> Just contains+    +    wName = show $ typeOf w+    wMunged = mungeName wName+    wDType = dataTypeOf w+    wCtrs = if isAlgType wDType then dataTypeConstrs wDType else []++    -- The module prefix of this type, so we can use it in constructor names.+    modPrefix+        = if '.' `elem` (takeWhile (\c -> isAlphaNum c || c == '.') wName)+            then takeWhile (/= '.') wName ++ "."+            else ""++    ctrArgs ctr+        = gmapQ DataBox (fromConstr ctr :: t)+    ctrArgTypes types+        = [show $ typeOf w | DataBox w <- types]++    -- Given the context (a list of instance requirements), the left-hand ops,+    -- the right-hand ops, and a list of lines for the body of the class, generates+    -- an instance.+    --+    -- For GenOneClass this will be an instance of AlloyA.+    --+    -- For GenClassPerType this will be an instance of AlloyAFoo (or whatever)+    --+    -- For GenSlowDelegate this will be an instance of AlloyA', with the first+    -- and last arguments swapped.+    genInst :: [String] -> String -> String -> [String] -> [String]+    genInst context ops0 ops1 body+      = ["instance (" ++ concat (intersperse ", " context) ++ ") =>"+        ,"         " ++ contextSameType ops0 ops1 ++ " where"+        ] ++ map ("  " ++) body++    -- Generates the name of an instance for the same type with the given two ops+    -- sets.  The class name will be the same as genInst.+    contextSameType :: String -> String -> String+    contextSameType ops0 ops1 = show genClassType ++ case genClass of+      GenOneClass -> " (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1+      GenClassPerType -> wMunged ++" " ++ ops0 ++ " " ++ ops1+      GenSlowDelegate -> "' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")"++    -- Generates the name of an instance for a different type (for processing children).+    --  This will be AlloyA or AlloyA'.+    contextNewType :: String -> String -> String -> String+    contextNewType cName ops0 ops1 = show genClassType ++ case genClass of+      GenOneClass -> " (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1+      GenClassPerType -> " (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1+      GenSlowDelegate -> "' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")"+      ++    -- The function to define in the body, and also to use for processing the same+    -- type.+    funcSameType :: FuncType -> String+    funcSameType func = case genClass of+      GenClassPerType -> base ++ wMunged+      GenOneClass -> base+      GenSlowDelegate -> base ++ "'"+      where+        base = show func++    -- The function to use for processing other types+    funcNewType :: FuncType -> String+    funcNewType func = case genClass of+      GenClassPerType -> base+      GenOneClass -> base+      GenSlowDelegate -> base ++ "'"+      where+        base = show func++    terminator :: String+    terminator = case genClassType of+      ClassAlloy -> "BaseOp"+      ClassAlloyA -> "BaseOpA"+      ClassAlloyARoute -> "BaseOpARoute"++    cons :: String+    cons = case genClassType of+      ClassAlloy -> ":-"+      ClassAlloyA -> ":-*"+      ClassAlloyARoute -> ":-@"++    funcs :: [FuncType]+    funcs = funcsForClass genClassType++    justData :: String+    justData = case genClassType of+      ClassAlloyARoute -> "(v, _)"+      _ -> "v"++    hasRoute = genClassType == ClassAlloyARoute++    -- | An instance that describes what to do when we have no transformations+    -- left to apply.  You can pass it an override for the case of processing children+    -- (and the types that make up the children).+    baseInst :: Maybe ([DataBox], ClassType -> (FuncType -> String, FuncType -> String) -> [String]) -> [String]+    baseInst mdoChildren+        = concat+          [genInst context terminator ("(f " ++ cons ++ " ops)") $+              maybe+                (concat+                [if isAlgType wDType+                    -- An algebraic type: apply to each child if we're following.+                    then (concatMap (constrCase b) wCtrs)+                    -- A primitive (or non-represented) type: just return it.+                    else [funcSameType b ++ " _ _ " ++ justData ++ " = " ++ funcPlain b ++ " v"]+                | b <- funcs])+                (\(_,f) -> f genClassType (funcSameType, funcNewType)) mdoChildren+          ,genInst [] terminator terminator+             [funcSameType b ++ " _ _ " ++ justData ++ " = " ++ funcPlain b ++ " v" | b <- funcs]+          ,if genOverlapped == GenWithoutOverlapped then [] else+            genInst+              [ contextSameType "r" "ops" ]+              ("(a " ++ cons ++ " r)") "ops" +                [funcSameType b ++ " (_ " ++ cons ++ " rest) ops vr = " ++ funcSameType b ++ " rest ops vr"+                | b <- funcs]+          ,if genClass == GenClassPerType+             then error "GenClassPerType currently unsupported" {-["class AlloyARoute" ++ wMunged ++ " o o' where"]+                  ++ concat [+                  ,"  " ++ funcSameType b ++ " :: Monad m => o m outer -> o' m outer -> (" ++ wName+                    ++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")"+                  ,"  " ++ funcSameType b ++ " :: Applicative a => o a outer -> o' a outer -> (" ++ wName+                    ++ ", Route (" ++ wName ++ ") outer) -> a (" ++ wName ++ ")"+                  | b <- funcs]+                  ,""+                  ,"instance (" ++ contextSameType "o0" "o1" ++ ") =>"+                  ,"         AlloyARoute (" ++ wName ++ ") o0 o1 where"+                  ,"  transformMRoute = " ++ funcSameType True+                  ,"  transformARoute = " ++ funcSameType False+                  ] -}+             else []+          ]+      where+        -- | Class context for 'baseInst'.+        -- We need an instance of Alloy for each of the types directly contained within+        -- this type, so we can recurse into them.+        context :: [String]+        context+          = [ contextNewType argType ("(f " ++ cons ++ " ops)") terminator+            | argType <- nub $ sort $ concatMap ctrArgTypes $+                maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]++    -- | A 'transformM' case for a particular constructor of this (algebraic)+    -- data type: pull the value apart, apply 'transformM' to each part of it,+    -- then stick it back together.+    constrCase :: FuncType -> Constr -> [String]+    constrCase b ctr+        = [ funcSameType b ++ " _ " ++ (if argNums == [] then "_" else "ops") +++            " (" ++ ctrInput ++ (if hasRoute then " , " ++ (if argNums == [] then "_" else "rt") else "") ++ ")"+          , "    = " ++ funcPlain b ++ " " ++ ctrName+          ] +++          [ " " ++ funcAp b ++ " (" ++ funcNewType b ++ " ops " ++ terminator ++ " (a" ++ show i+                        ++ (if hasRoute then ", rt @-> makeRoute [" ++ show i ++ "] "+                        ++ "(\\f (" ++ ctrMod ++ ") -> f b" ++ show i+                        ++ " >>= (\\b" ++ show i ++ " -> return (" ++ ctrMod ++ ")))"+                          else "") ++ "))"+           | i <- argNums]+      where+        argNums = [0 .. ((length $ ctrArgs ctr) - 1)]+        ctrS = show ctr+        ctrName = modPrefix ++ ctrS+        makeCtr vs = ctrName ++ concatMap (" " ++) vs+        ctrInput = makeCtr ["a" ++ show i | i <- argNums]+        ctrMod = makeCtr ["b" ++ show i | i <- argNums]++    -- | An instance that describes how to apply -- or not apply -- a+    -- transformation.+    otherInst :: Data s => Int -> Set.Set Int -> s -> Int -> [String]+    otherInst wKey containedKeys c cKey+        = if not shouldGen then [] else+            genInst context+                    ("((" ++ cName ++ ") " ++ cons ++ " r)")+                    "ops"+                    impl+      where+        cName = show $ typeOf c+        (shouldGen, context, impl)+          -- This type matches the transformation: apply it.+          | wKey == cKey+            = (True+              ,[]+              ,[funcSameType b ++ " (f " ++ cons ++ " _) _ vr = f vr" | b <- funcs])+          -- This type might contain the type that the transformation acts+          -- upon+          | cKey `Set.member` containedKeys+            = (True+              ,[contextSameType "r" ("((" ++ cName ++ ") " ++ cons ++ " ops)")]+              ,[funcSameType b ++ " (f " ++ cons ++ " rest) ops vr = " ++ funcSameType b ++ " rest (f " ++ cons ++ " ops) vr"+               | b <- funcs])+          -- This type can't contain the transformed type; just move on to the+          -- next transformation.+          | genOverlapped == GenWithoutOverlapped+            = (True+              ,[contextSameType "r" "ops"]+              ,[funcSameType b ++ " (_ " ++ cons ++ " rest) ops vr = " ++ funcSameType b ++ " rest ops vr"+               | b <- funcs])+          -- This is covered by one big overlapping instance:+          | otherwise = (False,[],[])++-- | The lines in the header that form the import statements necessary for the+-- Alloy instances.+instanceImports :: [String]+instanceImports = map ("import " ++) ["Control.Applicative", "Control.Monad", "Data.Generics.Alloy"]++-- | Like 'instanceImports' but also adds the lines needed for maps and sets.+-- If you use 'genMapInstance' or 'genSetInstance', use this function, otherwise+-- 'instanceImports' will suffice.+instanceImportsMapSet :: [String]+instanceImportsMapSet = instanceImports +++  map ("import " ++) ["Data.Map(Map)", "qualified Data.Map as Map"+                     ,"Data.Set(Set)", "qualified Data.Set as Set"+                     ,"qualified Data.Traversable as T"+                     ]++-- | Generates all the given instances (eliminating any duplicates)+-- with the given options.  The return is a list of lines of code.  This should+-- then be written to a Haskell module with the appropriate header.+genInstances :: GenInstanceConfig -> [GenInstance] -> IO [String]+genInstances opts insts+  =  do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts])+        let inst = [instancesFrom+                      (genOverlapped opts)+                      (genClass opts)+                      classType+                      (justBoxes typeMap)+                      w+                   | DataBox w <- map witness $ justBoxes typeMap,+                     classType <- classTypes]+        inst' <- sequence inst+        return $ concat inst'+  where+    classTypes = concat+      [ [ClassAlloy | genPure opts]+      , [ClassAlloyA | genEffect opts]+      , [ClassAlloyARoute | genRoute opts]+      ]++-- | The line with a LANGUAGE pragma detailed all the extensions needed.  This+-- is automatically written by 'writeInstances' and 'writeInstancesTo' at the top+-- of the file, but you may want to use it if you are using 'genInstances'.+languageExtras :: GenOverlappedOption -> String+languageExtras opt = "{-# LANGUAGE TypeOperators, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances"+  ++ if opt == GenWithOverlapped+       then ",OverlappingInstances #-}"+       else "#-}"++-- | Generates the instances according to the options and writes it to stdout with+-- the given header (the header is a list of lines without newline characters).+--+-- The configuration can be obtained from 'justPure' (for example) or constructing+-- the configuration yourself.  The list of 'GenInstance' can be obtained through+-- 'genInstance'.  The header will generally be something like:+-- +-- > "module FooInstances where" : "import qualified Foo" : instanceImports+writeInstances :: GenInstanceConfig -> [GenInstance] -> [String] -> IO ()+writeInstances opts inst header+  = do instLines <- genInstances opts inst+       putStr (unlines (languageExtras (genOverlapped opts) : (header ++ instLines)))++-- | Generates the instances according to the options and writes it to the given filename with+-- the given header (the header is a list of lines without newline characters).+writeInstancesTo :: GenInstanceConfig -> [GenInstance] -> [String]+  -> FilePath -> IO ()+writeInstancesTo opts inst header fileName+  = do instLines <- genInstances opts inst+       writeFile fileName (unlines (languageExtras (genOverlapped opts) : (header ++ instLines)))+++--{{{ Various SYB-based functions that we don't export, for discovering contained types:++-- | A type that can contain any 'Data' item.+data DataBox = forall t. Data t => DataBox t++instance Eq DataBox where+  (==) (DataBox x) (DataBox y) = typeOf x == typeOf y+++type TypeMap = Map Int (String, Witness)+type TypeMapM = StateT TypeMap IO++typeKey :: Typeable t => t -> IO Int+typeKey x = typeRepKey $ typeOf x++findTypesIn' :: Data t => (DataBox -> Maybe [DataBox]) -> t -> IO TypeMap+findTypesIn' f x = execStateT (findTypesIn f x) Map.empty++-- | Given a starting value, find all the types that could possibly be inside+-- it.+findTypesIn :: Data t => (DataBox -> Maybe [DataBox]) -> t -> TypeMapM ()+findTypesIn custom start = doType start+  where+    doType :: Data t => t -> TypeMapM ()+    doType x+        =  do map <- get+              key <- liftIO $ typeRepKey rep+              when (not $ key `Map.member` map) $+                 do modify $ Map.insert key (reps, Plain (DataBox x))+                    case custom $ DataBox x of+                      Just inside -> sequence_ [doType y | DataBox y <- inside]+                      Nothing ->                  +                        when (isAlgType dtype) $+                          mapM_ doConstr $ dataTypeConstrs dtype+      where+        rep = typeOf x        +        reps = show rep+        dtype = dataTypeOf x++        doConstr :: Constr -> TypeMapM ()+        doConstr ctr+            = sequence_ [doType x' | DataBox x' <- args]+          where+            args = gmapQ DataBox (asTypeOf (fromConstr ctr) x)++-- | Reduce a 'TypeMap' to a list of 'Witness'es, sorted by name.+justBoxes :: TypeMap -> [Witness]+justBoxes = map snd . sortBy (comparing fst) . Map.elems++--}}}

@@ -0,0 +1,91 @@+-- Alloy.+-- Copyright (c) 2008-2009, University of Kent.+-- 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 the University of Kent nor the names of its+--    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.++-- | The module containing the Alloy type-class for working with pure functions+-- (of the type @a -> a@).+module Data.Generics.Alloy.Pure where++-- | The Alloy type-class for pure functions, to be used with sets of+-- operations constructed from 'BaseOp' and ':-'.  You are unlikely to need to+-- use 'transform' directly; instead use 'makeRecurse' and 'makeDescend'.+--+-- The first parameter to the type-class is the type currently being operated+-- on, the second parameter is the set of operations to perform directly on+-- the type, and the third parameter is the set of operations to perform on+-- its children (if none of the second parameter operations can be applied).+class Alloy t o o' where+  transform :: o -> o' -> t -> t++-- | A type representing a modifier function that applies the given ops+-- (opT) directly to the given type (t).+type Recurse opT = forall t. Alloy t opT BaseOp => t -> t++-- | Given a set of operations, makes a modifier function that applies the+-- operations directly to the given type, and then to its children, until it+-- has been applied to all the largest instances of that type.+makeRecurse :: opT -> Recurse opT+makeRecurse ops = transform ops baseOp++-- | A type representing a modifier function that applies the given ops+-- (opT) to the children of the given type (t).+type Descend opT = forall t. Alloy t BaseOp opT => t -> t++-- | Given a set of operations, makes a descent modifier function that applies+-- the operation to the type's children, and further down, until it has been applied+-- to all the largest instances of that type.+makeDescend :: opT -> Descend opT+makeDescend ops = transform baseOp ops++-- | The type of the empty set of pure operations.+data BaseOp = BaseOp++-- | The function giving the empty set of pure operations.+baseOp :: BaseOp+baseOp = BaseOp++-- | The type that extends an opset (opT) to be applied to the given type (t).+-- This is for use with the 'Alloy' type-class.  A set of operations that operates+-- on @Foo@, @Bar@ and @Baz@ can be constructed so:+--+-- > ops :: Foo :- Bar :- Baz :- BaseOp+-- > ops = doFoo :- doBar :- doBaz :- baseOp+-- >+-- > doFoo :: Foo -> Foo+-- > doBar :: Bar -> Bar+-- > doBaz :: Baz -> Baz+data t :- opT = (t -> t) :- opT++infixr 7 :-++-- | A handy synonym for an opset with only one item, to use with 'Alloy'.+type OneOp t = t :- BaseOp++-- | A handy synonym for an opset with only two items, to use with 'Alloy'.+type TwoOp s t = s :- t :- BaseOp+

@@ -0,0 +1,199 @@+-- Alloy.+-- Copyright (c) 2008-2009, University of Kent.+-- 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 the University of Kent nor the names of its+--    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.++-- | A slightly experimental add-on for Alloy involving the idea of routes to a+-- particular part of a tree.+module Data.Generics.Alloy.Route+  (Route, routeModify, routeModifyM, routeGet, routeSet, (@->), identityRoute, routeId, routeList,+    makeRoute, routeDataMap, routeDataSet, AlloyARoute(..), BaseOpARoute(..), baseOpARoute,+      (:-@)(..), OneOpARoute, TwoOpARoute)+  where++import Control.Applicative+import Control.Monad.Identity+import Control.Monad.State++import qualified Data.Map as Map+import qualified Data.Set as Set++-- | A Route is a way of navigating to a particular node in a tree structure.+--+-- Let's say that you have some binary tree structure:+--+-- > data BinTree a = Leaf a | Branch (BinTree a) (BinTree a)+--+-- Suppose you then have a big binary tree of integers, potentially with duplicate values,+-- and you want to be able to modify a particular integer.  You can't modify in-place,+-- because this is a functional language.  So you instead want to be able to apply+-- a modify function to the whole tree that really just modifies the particular+-- integer, deep within the tree.+--+-- To do this you can use a route:+-- +-- > myRoute :: Route Int (BinTree Int)+--+-- You apply it as follows (for example, to increment the integer):+--+-- > routeModify myRoute (+1) myTree+--+-- This will only work if the route is valid on the given tree.+--+-- The usual way that you get routes is via the traversal functions in the module.+--+-- Another useful aspect is composition.  If your tree was in a tree of trees:+--+-- > routeToInnerTree :: Route (BinTree Int) (BinTree (BinTree Int))+--+-- You could compose this with the earlier route:+-- +-- > routeToInnerTree @-> myRoute :: Route Int (BinTree (BinTree Int))+-- +-- These routes are a little like zippers, but rather than building a new data+-- type to contain the zipped version and the re-use aspect, this is just a+-- simple add-on to apply a modification function in a particular part of the+-- tree.  Multiple routes can be used to modify the same tree, which is also+-- useful.+--+-- Routes support Eq, Show and Ord.  All these instances represent a route as a+-- list of integers: a route-map.  [0,2,1] means first child (zero-based), then+-- third child, then second child of the given data-type.  Routes are ordered using+-- the standard list ordering (lexicographic) over this representation.+data Route inner outer = Route [Int] (forall m. Monad m => (inner -> m inner) -> (outer -> m outer))++instance Eq (Route inner outer) where+  (==) (Route xns _) (Route yns _) = xns == yns++instance Ord (Route inner outer) where+  compare (Route xns _) (Route yns _) = compare xns yns++instance Show (Route inner outer) where+  show (Route ns _) = "Route " ++ show ns++-- | Gets the integer-list version of a route.  See the documentation of 'Route'.+routeId :: Route inner outer -> [Int]+routeId (Route ns _) = ns++-- | Given an index (zero is the first item), forms a route to that index item+-- in the list.  So for example:+--+-- > routeModify (routeList 3) (*10) [0,1,2,3,4,5] == [0,1,2,30,4,5]+-- +routeList :: Int -> Route a [a]+routeList 0 = Route [0] (\f (x:xs) -> f x >>= (\x' -> return (x': xs)))+routeList n = Route [1] (\f (x:xs) -> f xs >>= (\xs' -> return (x:xs'))) @-> routeList (n-1)++-- | Constructs a Route to the key-value pair at the given index (zero-based) in+-- the ordered map.  Routes involving maps are difficult because Map hides its+-- internal representation.  This route secretly boxes the Map into a list of pairs+-- and back again when used.  The identifiers for map entries (as used in the integer+-- list) are simply the index into the map as passed to this function.+routeDataMap :: Ord k => Int -> Route (k, v) (Map.Map k v)+routeDataMap n = Route [n] (\f m -> let (pre, x:post) = splitAt n (Map.toList m)+  in do x' <- f x+        return $ Map.fromList $ pre ++ (x':post))++-- | Constructs a Route to the value at the given index (zero-based) in the ordered+-- set.  See the documentation for 'routeDataMap', which is nearly identical to+-- this function.+routeDataSet :: Ord k => Int -> Route k (Set.Set k)+routeDataSet n = Route [n] (\f m -> let (pre, x:post) = splitAt n (Set.toList m)+  in do x' <- f x+        return $ Set.fromList $ pre ++ (x':post))+++-- | Applies a pure modification function using the given route.+routeModify :: Route inner outer -> (inner -> inner) -> (outer -> outer)+routeModify (Route _ wrap) f = runIdentity . wrap (return . f)++-- | Applies a monadic modification function using the given route.+routeModifyM :: Monad m => Route inner outer -> (inner -> m inner) -> (outer -> m+  outer)+routeModifyM (Route _ wrap) = wrap++-- | Given a route, gets the value in the large data structure that is pointed+-- to by that route.+routeGet :: Route inner outer -> outer -> inner+routeGet route = flip execState undefined . routeModifyM route (\x -> put x >> return x)++-- | Given a route, sets the value in the large data structure that is pointed+-- to by that route.+routeSet :: Route inner outer -> inner -> outer -> outer+routeSet route x = routeModify route (const x)++-- | Composes two routes together.  The outer-to-mid route goes on the left hand+-- side, and the mid-to-inner goes on the right hand side to form an outer-to-inner+-- route.+(@->) :: Route mid outer -> Route inner mid -> Route inner outer+(@->) (Route outInds outF) (Route inInds inF) = Route (outInds ++ inInds) (outF+  . inF)++-- | The identity route.  This has various obvious properties:+--+-- > routeGet identityRoute == id+-- > routeSet identityRoute == const+-- > routeModify identityRoute == id+-- > identityRoute @-> route == route+-- > route @-> identityRoute == route+identityRoute :: Route a a+identityRoute = Route [] id++-- | Given the integer list of identifiers and the modification function, forms+-- a Route.  It is up to you to make sure that the integer list is valid as described+-- in the documentation of 'Route', otherwise routes constructed this way and via+-- the Alloy functions may exhibit strange behaviours when compared.+makeRoute :: [Int] -> (forall m. Monad m => (inner -> m inner) -> (outer -> m outer))+  -> Route inner outer+makeRoute = Route++-- | An extension to 'AlloyA' that adds in 'Route's.  The opsets are now parameterised+-- over both the monad/functor, and the outer-type of the route.+class AlloyARoute t o o' where+  transformMRoute :: Monad m => o m outer -> o' m outer -> (t, Route t outer) -> m t+  transformARoute :: Applicative f => o f outer -> o' f outer -> (t, Route t outer) -> f t++-- | Like 'baseOpA' but for 'AlloyARoute'.+baseOpARoute :: BaseOpARoute m outer+baseOpARoute = BaseOpARoute++-- | The type that extends an applicative/monadic opset (opT) in the given+-- functor/monad (m) to be applied to the given type (t) with routes to the+-- outer type (outer).  This is for use with the 'AlloyARoute' class.+data (t :-@ opT) m outer = ((t, Route t outer) -> m t) :-@ (opT m outer)++infixr 7 :-@++-- | The terminator for opsets with 'AlloyARoute'.+data BaseOpARoute m outer = BaseOpARoute+++-- | A handy synonym for a monadic/applicative opset with only one item, to use with 'AlloyARoute'.+type OneOpARoute t = t :-@ BaseOpARoute++-- | A handy synonym for a monadic/applicative opset with only two items, to use with 'AlloyARoute'.+type TwoOpARoute s t = (s :-@ t :-@ BaseOpARoute)

@@ -0,0 +1,207 @@+-- Alloy.+-- Copyright (c) 2008-2009, University of Kent.+-- 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 the University of Kent nor the names of its+--    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.++-- | A module of helper functions for use with Alloy.  Most of the functions+-- have versions for pure functions (without suffix), applicative functors (A+-- suffix) and monads (M suffix) and sometimes the monadic version again with routes.+-- Generally, only the pure version is documented.  The key functions you are likely+-- to need (or their suffixed versions) are 'applyBottomUp' and 'applyBottomUp2',+-- and 'listifyDepth'.+module Data.Generics.Alloy.Schemes where++import Control.Applicative+import Control.Monad.State++import Data.Generics.Alloy.Pure+import Data.Generics.Alloy.Effect+import Data.Generics.Alloy.Route++-- * Functions to easily apply transformations throughout a data structure++-- | Given a function that applies to a particular type (@s@), automatically+-- applies that function to every instance of @s@ in a larger structure of+-- type @t@, performing the transformations in a bottom-up fashion.  It does a+-- depth first traversal in order of a constructor's children, descending+-- first and applying the function afterwards on the way back up.+--+-- This is equivalent to SYB's everywhere function, as it applies the function+-- everywhere it can throughout the data structure.  The function will not be applied+-- to the results of your transformation, so the function cannot end up in infinite+-- loop (unless the value you apply the function to is infinite!).+applyBottomUp :: (Alloy t (OneOp s) BaseOp,+                  Alloy s BaseOp (OneOp s)) =>+                 (s -> s) -> t -> t+applyBottomUp f = makeRecurse ops+  where+    ops = makeBottomUp ops f :- baseOp++applyBottomUpA :: (AlloyA t (OneOpA s) BaseOpA,+                   AlloyA s BaseOpA (OneOpA s), Applicative f) =>+                  f (s -> s) -> t -> f t+applyBottomUpA f = makeRecurseA ops+  where+    ops = makeBottomUpA ops f :-* baseOpA++applyBottomUpM :: (AlloyA t (OneOpA s) BaseOpA,+                   AlloyA s BaseOpA (OneOpA s), Monad m) =>+                  (s -> m s) -> t -> m t+applyBottomUpM f = makeRecurseM ops+  where+    ops = makeBottomUpM ops f :-* baseOpA++applyBottomUpMRoute :: (AlloyARoute t (OneOpARoute s) (BaseOpARoute),+                        AlloyARoute s (BaseOpARoute) (OneOpARoute s),+                        Monad m) =>+                       ((s, Route s t) -> m s) -> t -> m t+applyBottomUpMRoute f x = transformMRoute ops baseOpARoute (x, identityRoute)+  where+    ops = makeBottomUpMRoute ops f :-@ baseOpARoute+++-- | As 'applyBottomUp', but applies both functions whereever it can in the+-- data structure.  It is very important that @sA@ is not the same type as+-- @sB@ -- odd results will occur if they are the same type.  It is perfectly+-- valid for @sA@ to contain @sB@ or vice versa; in this case, the smaller+-- type will be processed first (as this is a bottom-up traversal) and the+-- larger type processed later on in the ascent (towards the root) of the+-- tree.+applyBottomUp2 :: (Alloy t (TwoOp sA sB) BaseOp,+                  Alloy sA BaseOp (TwoOp sA sB),+                  Alloy sB BaseOp (TwoOp sA sB)) =>+                 (sA -> sA) -> (sB -> sB) -> t -> t+applyBottomUp2 fA fB = makeRecurse ops+  where+    ops = makeBottomUp ops fA :- makeBottomUp ops fB :- baseOp++applyBottomUpA2 :: (AlloyA t (TwoOpA sA sB) (BaseOpA),+                    AlloyA sA (BaseOpA) (TwoOpA sA sB),+                    AlloyA sB (BaseOpA) (TwoOpA sA sB),+                    Applicative f+                   ) =>+                   f (sA -> sA) -> f (sB -> sB) -> t -> f t+applyBottomUpA2 fA fB = makeRecurseA ops+  where+    ops = makeBottomUpA ops fA :-* makeBottomUpA ops fB :-* baseOpA++applyBottomUpM2 :: (AlloyA t (TwoOpA sA sB) (BaseOpA),+                    AlloyA sA (BaseOpA) (TwoOpA sA sB),+                    AlloyA sB (BaseOpA) (TwoOpA sA sB),+                    Monad m+                   ) =>+                   (sA -> m sA) -> (sB -> m sB) -> t -> m t+applyBottomUpM2 fA fB = makeRecurseM ops+  where+    ops = makeBottomUpM ops fA :-* makeBottomUpM ops fB :-* baseOpA++applyBottomUpMRoute2 :: (AlloyARoute t (TwoOpARoute sA sB) (BaseOpARoute),+                        AlloyARoute sA (BaseOpARoute) (TwoOpARoute sA sB),+                        AlloyARoute sB (BaseOpARoute) (TwoOpARoute sA sB),+                        Monad m) =>+                       ((sA, Route sA t) -> m sA)+                       -> ((sB, Route sB t) -> m sB)+                       -> t -> m t+applyBottomUpMRoute2 fA fB x = transformMRoute ops baseOpARoute (x, identityRoute)+  where+    ops = makeBottomUpMRoute ops fA :-@ makeBottomUpMRoute ops fB :-@ baseOpARoute+++-- * Listify functions that return lists of items that satisfy given criteria++-- | Given a function that examines a type @s@ and gives an answer (True to include+-- the item in the list, False to drop it), finds all items of type @s@ in some+-- larger item (of type @t@) that satisfy this function, listed in depth-first+-- order.+listifyDepth :: (AlloyA t (OneOpA s) BaseOpA+                ,AlloyA s BaseOpA (OneOpA s)) => (s -> Bool) -> t -> [s]+-- We use applyBottomUp because we are prepending to the list.  If we prepend from+-- the bottom up, that's the same as appending from the top down, which is what+-- this function is meant to be doing.+listifyDepth qf = flip execState [] . applyBottomUpM qf'+  where+    qf' x = if qf x then modify (x:) >> return x else return x++listifyDepthRoute :: (AlloyARoute t (OneOpARoute s) (BaseOpARoute)+                     ,AlloyARoute s (BaseOpARoute) (OneOpARoute s))+                     => ((s, Route s t) -> Bool) -> t -> [(s, Route s t)]+listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf'+  where+    qf' x = if qf x then modify (x:) >> return (fst x) else return (fst x)++-- * Check functions to apply monadic checks throughout a data structure++-- | Given a monadic function that operates on items of type @s@ (without modifying+-- them), applies the function to all items of types @s@ within an item of type+-- @t@, in depth-first order.+--+-- This can be used, for example, to perform checks on items in an error monad,+-- or to accumulate information in a state monad, or to print out the structure+-- in a writer or IO monad.+checkDepthM :: (Monad m, AlloyA t (OneOpA s) BaseOpA+                       , AlloyA s BaseOpA (OneOpA s)) => (s -> m ()) -> t -> m ()+checkDepthM f x = applyBottomUpM (\x -> f x >> return x) x >> return ()++checkDepthM2 :: (Monad m, AlloyA t (TwoOpA r s) (BaseOpA)+                        , AlloyA r (BaseOpA) (TwoOpA r s)+                        , AlloyA s (BaseOpA) (TwoOpA r s)+                        ) =>+  (r -> m ()) -> (s -> m ()) -> t -> m ()+checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x)+                                     (\y -> g y >> return y) x >> return ()+++++-- * Adding traversal to modifiers++-- | Given a set of operations and a modifier function, augments that modifier+-- function to first descend into the value before then applying the modifier function.+--  This can be used to perform a bottom-up depth-first traversal of a structure+-- (see the implementation of 'applyBottomUp').+--+-- You are unlikely to need these functions much yourself; either use 'applyBottomUp'+-- and similar to apply a function everywhere, or if you need more fine-grained+-- control over the descent, it is usually better to handle the descent in your+-- own functions.+makeBottomUp :: Alloy t BaseOp opT => opT -> (t -> t) -> t -> t+makeBottomUp ops f v = f (makeDescend ops v)++makeBottomUpA :: (AlloyA t BaseOpA opT, Applicative f) => opT f -> f (t -> t) -> t -> f t+makeBottomUpA ops f v = f <*> makeDescendA ops v++makeBottomUpM :: (AlloyA t BaseOpA opT, Monad m) => opT m -> (t -> m t) -> t -> m t+makeBottomUpM ops f v = makeDescendM ops v >>= f++makeBottomUpMRoute :: (Monad m, AlloyARoute t BaseOpARoute opT) =>+  opT m outer -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t+makeBottomUpMRoute ops f (v, r)+  = do v' <- transformMRoute baseOpARoute ops (v, r)+       f (v', r)+++

@@ -0,0 +1,27 @@+Copyright (c) 2008-2009, University of Kent.+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 the University of Kent nor the names of its+      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.

@@ -0,0 +1,5 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+

@@ -0,0 +1,68 @@+Name: alloy+Version: 1.0.0+License: BSD3+License-File: LICENSE+Author: Neil Brown and Adam Sampson+Copyright: Copyright 2008-2009, University of Kent+Maintainer: neil@twistedsquare.com+Cabal-Version: >= 1.2.3+Build-type: Simple+Synopsis: Generic programming library+Description: Alloy is a generic programming library for performing traversals+             of data and applying specific operations to certain types.  More+	     information is available in the tutorial+	     (<http://twistedsquare.com/Alloy-Tutorial.pdf>) and the draft+	     paper (<http://twistedsquare.com/Alloy.pdf>).+Category: Generics+Tested-With: GHC==6.8.2, GHC==6.10.3+Extra-Source-Files: tutorial/tutorial.tex+                    tutorial/CompanyDatatypes.lhs+                    tutorial/Constraints.lhs+                    tutorial/Effects.lhs+                    tutorial/EffectsSelective.lhs+                    tutorial/GenTypes.lhs+                    tutorial/GenTypesMapSet.lhs+                    tutorial/MapSet.lhs+                    tutorial/MapSetExample.lhs+                    tutorial/Paradise.lhs+                    tutorial/Query.lhs+                    tutorial/Routes.lhs+                    tutorial/Selective.lhs++Library+  if (impl(ghc < 6.10))+    Build-Depends: base >= 3 && < 4, containers, mtl+  else+    Build-Depends: base >= 4 && < 5, containers, mtl, syb++  Exposed-modules: Data.Generics.Alloy+                   Data.Generics.Alloy.Effect+                   Data.Generics.Alloy.GenInstances+                   Data.Generics.Alloy.Pure+                   Data.Generics.Alloy.Route+                   Data.Generics.Alloy.Schemes++  Extensions: ExistentialQuantification+              FlexibleContexts+              FlexibleInstances+              KindSignatures+              MultiParamTypeClasses+              Rank2Types+              ScopedTypeVariables+              TypeOperators++-- Rank2Types for the Route Monad stuff+--   (surely, this could be removed somehow?)+-- ExistentialQuantification for DataBox+--   (could be removed if we generate instances with TH or Derive)+-- MultiParamTypeClasses for the Alloy type-class+--   (unavoidable!)+-- TypeOperators for the opsets+--   (not going to change)+-- FlexibleContexts and FlexibleInstances all over the place+--   (unavoidable)+++++

@@ -0,0 +1,46 @@+Below are some sample data types, originally created by Ralf L\"ammel as part+of the paradise benchmark.  They are taken directly from+\url{http://www.cs.vu.nl/boilerplate/testsuite/paradise/CompanyDatatypes.hs}.+We will use them for our first few examples of using Alloy.++\begin{code}+{-# LANGUAGE DeriveDataTypeable #-}+module CompanyDatatypes where++import Data.Generics hiding (Unit)++-- The organisational structure of a company++data Company  = C [Dept]               deriving (Eq, Ord, Show, Typeable, Data)+data Dept     = D Name Manager [Unit]  deriving (Eq, Ord, Show, Typeable, Data)+data Unit     = PU Employee | DU Dept  deriving (Eq, Ord, Show, Typeable, Data)+data Employee = E Person Salary        deriving (Eq, Ord, Show, Typeable, Data)+data Person   = P Name Address         deriving (Eq, Ord, Show, Typeable, Data)+data Salary   = S Float                deriving (Eq, Ord, Show, Typeable, Data)+type Manager  = Employee+type Name     = String+type Address  = String++-- An illustrative company+genCom :: Company+genCom = C [D "Research" laemmel [PU joost, PU marlow],+            D "Strategy" blair   []]++-- A typo for the sake of testing equality;+-- (cf. lammel vs. laemmel)+genCom' :: Company+genCom' = C [D "Research" lammel [PU joost, PU marlow],+             D "Strategy" blair   []]++lammel, laemmel, joost, blair :: Employee+lammel  = E (P "Lammel" "Amsterdam") (S 8000)+laemmel = E (P "Laemmel" "Amsterdam") (S 8000)+joost   = E (P "Joost"   "Amsterdam") (S 1000)+marlow  = E (P "Marlow"  "Cambridge") (S 2000)+blair   = E (P "Blair"   "London")    (S 100000)++-- Some more test data+person1 = P "Lazy" "Home"+dept1   = D "Useless" (E person1 undefined) []+\end{code}+

@@ -0,0 +1,42 @@+So far, we have always used Alloy on known, definite types.  When you do this,+no type-class constraints are required as the compiler can go and find the+type-class instances for the definite types.  If you want to operate on+parameterised types, you will need to manually add some type-class+constraints.  In essence, you will need to copy the type-class constraints+from any Alloy function you make use of, such as makeDescend, applyBottomUp,+etc, that involves the parameterised type.  You can see all the constraints in+the documentation.  We will re-use our previous example to demonstrate:++\begin{code}+{-# LANGUAGE TypeOperators #-}+import CompanyDatatypes+import Data.Generics.Alloy+import Instances++increaseAllButResearch :: Alloy a (Dept :- Salary :- BaseOp) BaseOp =>+  Float -> a -> a+increaseAllButResearch k = makeRecurse ops+  where+    ops :: Dept :- Salary :- BaseOp+    ops = doDept :- incS k :- baseOp++    doDept :: Dept -> Dept+    doDept d@(D name _ _)+      | name == "Research" = d+      | otherwise = makeDescend ops d++incS :: Float -> Salary -> Salary+incS k (S s) = S (s * (1+k))++main = print $ increaseAllButResearch 0.1 genCom+\end{code}%$++The extra constraint included is taken from \lstinline|makeRecurse|.  The+first parameter of the \lstinline|Alloy| type-class is the type that the+operation (\lstinline|makeRecurse|) is applied to.  For+\lstinline|makeRecurse| the second operation set is full and the third is+empty; for \lstinline|makeDescend| the reverse would be true.  We only need+include the constraint for \lstinline|makeRecurse|, and not+\lstinline|makeDescend| because the former operates on \lstinline|a| whereas+the latter here acts on a definite type, with a definite opset.+

@@ -0,0 +1,38 @@+So far we have seen Alloy operating with pure functions.  Often, traversals+need to have effects.  Alloy supports effects with applicative functors, and+as a helpful common case of applicative functors: monads.  Consider the case+where we want to increase salaries in the company, until we run out of+budget.  For our example, which salaries are increased will be fairly+arbitrary (the order of the tree traversal), but such is life!  We will+maintain a remaining budget total in a state monad as we traverse.++To use effectful transformations, we must use the \lstinline|AlloyA|+type-class instead of \lstinline|Alloy|.  All of the helper functions we have+seen so far are available, with an \lstinline|A| suffix (for+\lstinline|Applicative|) and an \lstinline|M| suffix (for \lstinline|Monad|).++Here is the code for increasing the salaries up to a given budget:++\begin{code}+import CompanyDatatypes+import Data.Generics.Alloy+import Instances+import Control.Monad.State++increase :: Float -> Company -> Company+increase k c = evalState (applyBottomUpM (incS k) c) 1000++incS :: Float -> Salary -> State Float Salary+incS k (S s)+  = do budget <- get+       if diff > budget+         then return (S s)+         else do put $ budget - diff+                 return (S s')+  where+    s' = s * (1+k)+    diff = s' - s++main = print $ increase 0.1 genCom+\end{code}%$+

@@ -0,0 +1,46 @@+We can now put together two of our previous examples, to selectively increase+the salary of all those not in the research department, up to a given budget:+++\begin{code}+{-# LANGUAGE TypeOperators #-}+import CompanyDatatypes+import Data.Generics.Alloy+import Instances+import Control.Monad.State++increaseAllButResearch :: Float -> Company -> Company+increaseAllButResearch k c = evalState (makeRecurseM ops c) 15000+  where+    ops :: (Dept :-* Salary :-* BaseOpA) (State Float)+    ops = doDept :-* incS k :-* baseOpA++    doDept :: Dept -> State Float Dept+    doDept d@(D name _ _)+      | name == "Research" = return d+      | otherwise = makeDescendM ops d++incS :: Float -> Salary -> State Float Salary+incS k (S s)+  = do budget <- get+       if diff > budget+         then return (S s)+         else do put $ budget - diff+                 return (S s')+  where+    s' = s * (1+k)+    diff = s' - s++main = print $ increaseAllButResearch 0.1 genCom+\end{code}%$++The changes in the \lstinline|increaseAllButResearch| function are that the+\lstinline|:-| constructor has become \lstinline|:-*| in the effectful+version, and similarly \lstinline|baseOp| has become \lstinline|baseOpA|.  The+terminator is oblivious to whether the effect in question is an applicative+functor or a monad, hence there is only the \lstinline|A|-suffixed version.+The opset is then parameterised by the monad in question (the bracketing in+the type of \lstinline|ops| is important).++Apart from these small textual changes, it can be seen that the code is+roughly the same.

@@ -0,0 +1,30 @@+To generate instances, you must write a short Haskell program that uses the+\lstinline|Data.Generics.Alloy.GenInstances| module.  Here is the example for+the \lstinline|CompanyDatatypes| module:++\begin{code}+import CompanyDatatypes+import Data.Generics.Alloy.GenInstances++main :: IO ()+main = writeInstancesTo (allInstances GenWithoutOverlapped)+         [genInstance (undefined :: Company)]+         (["module Instances where"+          ,"import qualified CompanyDatatypes"+          ] ++ instanceImports)+         "Instances.hs"+\end{code}++The configuration options (the \lstinline|allInstances| call) can be ignored for+now, but we will return to them later.  This program will generate a file+named ``\verb$Instances.hs$'' which is a complete module with instances for+all the data types that can possibly be contained in the \lstinline|Company|+data type.   Note that the \lstinline|Company| datatype, and anything it+contains, must have a \lstinline|Data| instance.  This can be done+automatically in GHC by simply adding \lstinline|Typeable| and+\lstinline|Data| to the deriving clause for your data types.++You supply the header for the module yourself.  The three requirements for+Alloy are that you must import the \lstinline|Data.Generics.Alloy| module, and+(as a qualified import) the module(s) that contain the types you are+generating instances for.  If you generate all instances as we are, you must also import the \lstinline|Control.Applicative| and \lstinline|Control.Monad| modules (which we will return to later).

@@ -0,0 +1,26 @@+We will then need to generate some instances:++\begin{code}+import CompanyDatatypes+import MapSet+import Data.Generics.Alloy.GenInstances++main :: IO ()+main = writeInstancesTo (allInstances GenWithoutOverlapped)+         [genInstance (undefined :: Company)+         ,genInstance (undefined :: CompanyInfo)+         ,genMapInstance (undefined :: Person) (undefined :: Salary)+         ,genSetInstance (undefined :: Manager)]+         (["module MapSetInstances where"+          ,"import qualified CompanyDatatypes"+          ,"import qualified MapSet"+          ] ++ instanceImportsMapSet)+         "MapSetInstances.hs"+\end{code}++This is similar to our previous code for generating instances.  We call+\lstinline|genInstance| for \lstinline|Company| and \lstinline|CompanyInfo|+(neither contains the other, but between them they both contain all the data+types).  We call \lstinline|genMapInstance| for our map, passing the key and+value types as parameters, and similarly we call \lstinline|genSetInstance|.+Finally, we use \lstinline|instanceImportsMapSet| instead of \lstinline|instanceImports|.

@@ -0,0 +1,30 @@+Alloy builds its type-classes using the \lstinline|Data| instance for the+types given to it.  If you derive \lstinline|Data| and \lstinline|Typeable|+using the built-in GHC feature, this will work fine.  One problem is that the+popular container types, \lstinline|Map| and \lstinline|Set| do not derive+\lstinline|Data| in this way and by default Alloy will fail to work with them+properly.++As a workaround, Alloy includes two special functions,+\lstinline|genMapInstance| and \lstinline|genSetInstance|.  These functions+provide a view on maps as a collection of key-value pairs, and also allow+processing of elements in sets.  We will demonstrate this with a simple+example, first some new data types:++\begin{code}+module MapSet where++import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Generics+import CompanyDatatypes++type Payroll = Map.Map Person Salary++type Managers = Set.Set Manager++data CompanyInfo = CompanyInfo Payroll Managers+  deriving (Typeable, Data, Show)+\end{code}++

@@ -0,0 +1,54 @@+We can now use these instances to perform some operations on the data types.+First, we will define some operations to derive the \lstinline|CompanyInfo|+information, using a state monad:++\begin{code}+import CompanyDatatypes+import MapSet+import MapSetInstances+import Data.Generics.Alloy+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad.State++companyInfo :: Company -> CompanyInfo+companyInfo c = execState (applyBottomUpM2 doEmployee doDept c)+                          (CompanyInfo Map.empty Set.empty)+  where+    doEmployee :: Employee -> State CompanyInfo Employee+    doEmployee (E p s)+      = do modify $ \(CompanyInfo es ms) ->+             CompanyInfo (Map.insert p s es) ms+           return (E p s)+    +    doDept :: Dept -> State CompanyInfo Dept+    doDept d@(D _ m _)+      = do modify $ \(CompanyInfo es ms) ->+             CompanyInfo es (Set.insert m ms)+           return d+\end{code}++We can then perform further operations on the \lstinline|CompanyInfo| type.+For example, we can increase the salary of all employees with the letter `o'+in their name:++\begin{code}+incS :: Float -> Salary -> Salary+incS k (S s) = S (s * (1+k))++increaseOs :: Float -> CompanyInfo -> CompanyInfo+increaseOs k = applyBottomUp inc+  where+    inc :: (Person, Salary) -> (Person, Salary)+    inc (P n a, s)+      | 'o' `elem` n = (P n a, incS k s)+      | otherwise = (P n a, s)++main = print $ increaseOs 0.1 $ companyInfo genCom+\end{code}++Notice how we define the function to work on key-value pairs in order to+process the map entries.  If you wish to process the map itself differently,+you can define an operation on the map; the map instances we use here are+particularly useful for descending into maps (for example if the value in a+map can contain types you wish to process).

@@ -0,0 +1,22 @@+Having generated the instances, we can now write the paradise benchmark, that+modifies all the salaries in the company.  Since we are operating on all+instances of a particular data-type, we can use the helper function+\lstinline|applyBottomUp| (akin to \lstinline|everywhere| in SYB):++\begin{code}+import CompanyDatatypes+import Data.Generics.Alloy+import Instances++increase :: Float -> Company -> Company+increase k = applyBottomUp (incS k)++incS :: Float -> Salary -> Salary+incS k (S s) = S (s * (1+k))++main = print $ increase 0.1 genCom+\end{code}%$++This is the most basic use of Alloy.  There is also an+\lstinline|applyBottomUp2| function that takes two functions operating on+distinct types, and applies both of them throughout the data structure.

@@ -0,0 +1,31 @@+A better example of increasing salaries with a limited budget might be to set+a fixed proportional raise, based on the total salaries across the company.+An easy way to accomplish this is to first run a query on the company to find+the salaries, and secondly to traverse the tree performing the increases on+the salaries:++\begin{code}+import CompanyDatatypes+import Data.Generics.Alloy+import Instances++increase :: Float -> Company -> Company+increase k = applyBottomUp (incS k)++incS :: Float -> Salary -> Salary+incS k (S s) = S (s * (1+k))++totalSalary :: Company -> Float+totalSalary = sum . map (\(S s) -> s) . listifyDepth (const True)++main = print $ increase (5000 / totalSalary genCom) genCom+\end{code}%$++This code uses the \lstinline|listifyDepth| function, which is akin to SYB's+\lstinline|listify|.  Given a function of type \lstinline|s -> Bool|,+\lstinline|listifyDepth| returns a list of all items of type \lstinline|s|+that result in \lstinline|True|.  Here, all salaries are needed so+\lstinline|const True| is the suitable definition.  \lstinline|listifyDepth|+is implemented using a traversal with the \lstinline|State| monad, and this+method can be used to implement other similary query operations.+

@@ -0,0 +1,45 @@+As another example we will consider how to find the employee(s) with the+lowest salary in the company and increase just their salary.  This could be+done with a two-pass query, first finding the lowest salary, and second+traversing the entire tree to increment all employees with a matching salary.+We instead use this example to demonstrate routes, an experimental zipper-like feature.++\begin{code}+import CompanyDatatypes+import Data.Generics.Alloy+import Instances+import Control.Monad.State++increase :: Float -> Route Salary Company -> Company -> Company+increase k r = routeModify r (incS k)++incS :: Float -> Salary -> Salary+incS k (S s) = S (s * (1+k))++findMin :: Company -> [Route Salary Company]+findMin c = snd $ execState (applyBottomUpMRoute minSalary c) (Nothing, [])+  where+    minSalary :: (Salary, Route Salary Company)+                   -> State (Maybe Float, [Route Salary Company]) Salary+    minSalary (S s, r)+      = do (curMin, rs) <- get+           case fmap (compare s) curMin of+             Nothing -> put (Just s, [r])+             Just LT -> put (Just s, [r])+             Just EQ -> put (curMin, r : rs)+             Just GT -> return ()+           return (S s)++main = print $ foldr (increase 0.1) genCom (findMin genCom)+\end{code}%$++The route is a path into a tree of type \lstinline|Company|, to an item of+type \lstinline|Salary|.  This route can be used for getting, setting or+modifying, when applied to the same tree that it was derived from.  This means+that the whole tree does not need to be traversed again to alter a couple of+salaries, which can be a useful saving with large trees.++This strategy is vaguely similar to zippers, but uses mutation rather than any+more complex manipulations.  Multiple routes can be used to modify the+same tree, as long as the final nodes are disjoint (i.e. one does not contain+another).

@@ -0,0 +1,57 @@+The previous example applied the salary increase to all employees in the+company.  Often, traversals need to be more selective, based on nodes further+up (i.e. closer to the root) in the tree.  We will now consider how to+increase the salary of all employees except those that are anywhere in the+research department.  We must bear in mind that departments may contain+departments:++\begin{code}+{-# LANGUAGE TypeOperators #-}+import CompanyDatatypes+import Data.Generics.Alloy+import Instances++increaseAllButResearch :: Float -> Company -> Company+increaseAllButResearch k = makeRecurse ops+  where+    ops :: Dept :- Salary :- BaseOp+    ops = doDept :- incS k :- baseOp++    doDept :: Dept -> Dept+    doDept d@(D name _ _)+      | name == "Research" = d+      | otherwise = makeDescend ops d++incS :: Float -> Salary -> Salary+incS k (S s) = S (s * (1+k))++main = print $ increaseAllButResearch 0.1 genCom+\end{code}%$++There are several new concepts here.  The main concept is the opset (short for+operations set).  An opset is built using the \lstinline|:-| constructor in a+\textit{cons}-fashion, terminated by the \lstinline|baseOp| function (of+\lstinline|BaseOp| type).  The type of an opset mirrors its construction,+showing that it is an opset on the two types \lstinline|Dept| and+\lstinline|Salary|.  Usually the type of an opset can be inferred and thus it+is a matter of style whether to include the type.++An opset is used primarily with two functions: \lstinline|makeRecurse| and+\lstinline|makeDescend|.  Broadly, \lstinline|makeRecurse| is used to+begin a traversal, and \lstinline|makeDescend| is used to continue it; \lstinline|makeRecurse| applies the+operations to all the largest types (the first ones encountered in a+depth-first search) it can find, potentially including the argument you have+given it -- in contrast, \lstinline|makeDescend| begins with the type's+children.+The \lstinline|increaseAllButResearch| function uses \lstinline|makeRecurse|+to begin the traversal of the company.  However, \lstinline|doDept| must use+\lstinline|makeDescend| in order to operate on the children of the+\lstinline|Dept|.  If \lstinline|doDept| had used \lstinline|makeRecurse|, an+infinite loop would have resulted from \lstinline|doDept| continually being+applied to the same department.  ++The function works by examining the department name.  If the name is+\lstinline|"Research"|, the department is returned unaltered (as we do not+wish to alter any employees' salaries in research, even in sub-departments).+Otherwise, the traversal continues across the department, looking for further+sub-departments, and also salaries to increase as before.

@@ -0,0 +1,112 @@+\documentclass{article}++\usepackage{listings}+\lstnewenvironment{code}{}{}+\usepackage{hyperref}+\usepackage{color}+\usepackage{graphicx}++\definecolor{KBlue}{rgb}{0.0,0.2196,0.5098}    % 0, 56, 130+\definecolor{listinggray}{gray}{0.95}++\newcommand{\footnoteremember}[2]{+  \footnote{#2}+  \newcounter{#1}+  \setcounter{#1}{\value{footnote}}+}+\newcommand{\footnoterecall}[1]{\footnotemark[\value{#1}]}++\lstdefinelanguage[improved]{Haskell}+   % To separate out word keywords from symbol keywords for different formatting,+   % we define the word keywords as emph items (use emphstyle):+  {classoffset=0,+   %If we don't specify at least one "non-other" keyword, listings doesn't work, hence:+   morekeywords={hduisahfiuabfyasbyoasvbfuyvosf},+   otherkeywords={::,=,==,->,=>,>>,>>=,>>*,$,++,<-,<|>,<->,<||>,</>,\\,.,__,<&>},+   classoffset=1,+   morekeywords={data,forall,type,module,newtype,let,in,do,where,if,then,else,qualified,as,import},+   % For some (unknown) reason, setting classoffset = 0 again after this line+   % breaks the highlighting.+   morecomment=[l]{--},+%   morestring=[b]',+   morestring=[b]",+  }+%$+\lstset{+	language={[improved]Haskell},+	columns=flexible,+        backgroundcolor=\color{listinggray},+        frameround=tttt,+        frame=trbl,+        framerule=0.4pt,+	basicstyle=\small\sffamily,+	emphstyle=\bfseries,+        keywordstyle=[1]{\color{KBlue}\bfseries},+        keywordstyle=[0]{\color{KBlue}\bfseries\ttfamily},+	identifierstyle=,+	commentstyle=,+	stringstyle=\ttfamily,+	showstringspaces=false}+\thicklines++\title{Alloy tutorial}+\author{Neil C. C. Brown}++\begin{document}++\maketitle++\section*{Introduction}++This document is a tutorial for the Alloy generics library.  Alloy is similar+to other generics libraries, such as Scrap Your Boilerplate (SYB), Uniplate,+EMGM and all the rest.  Alloy tends to be quite fast (see our paper for+benchmarks) because it avoids traversing parts of the data structure that it+does not need to.++This is accomplished by generating type-class instances based on the+can-contain relation between types.  The current set of operations (opset) is+trimmed dynamically to remove types that can no longer be contained in the+data item being traversed.  For more details, see the draft paper.+%TODO++%\newpage+%\tableofcontents++\newpage+\section{Paradise Benchmark}+\input{CompanyDatatypes.lhs}+\newpage+\subsection{The Basics}+\input{GenTypes.lhs}+\input{Paradise.lhs}+\newpage+\subsection{Multiple Target Types and Controlled Descent}+\input{Selective.lhs}+\subsection{Type-Class Constraints}+\input{Constraints.lhs}++\newpage+\subsection{Effects}+\input{Effects.lhs}+\newpage+\input{EffectsSelective.lhs}++\newpage+\subsection{Queries}+\input{Query.lhs}++\newpage+\subsection{Routes}+\input{Routes.lhs}++\newpage+\subsection{Maps and Sets}+\input{MapSet.lhs}+\input{GenTypesMapSet.lhs}+\input{MapSetExample.lhs}++%\newpage+%\section{Frequently Asked Questions}++\end{document}