diff --git a/Data/Generics/Alloy.hs b/Data/Generics/Alloy.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Alloy.hs @@ -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 +-- () 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 + + diff --git a/Data/Generics/Alloy/Effect.hs b/Data/Generics/Alloy/Effect.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Alloy/Effect.hs @@ -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) diff --git a/Data/Generics/Alloy/GenInstances.hs b/Data/Generics/Alloy/GenInstances.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Alloy/GenInstances.hs @@ -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 + +--}}} diff --git a/Data/Generics/Alloy/Pure.hs b/Data/Generics/Alloy/Pure.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Alloy/Pure.hs @@ -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 + diff --git a/Data/Generics/Alloy/Route.hs b/Data/Generics/Alloy/Route.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Alloy/Route.hs @@ -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) diff --git a/Data/Generics/Alloy/Schemes.hs b/Data/Generics/Alloy/Schemes.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Alloy/Schemes.hs @@ -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) + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/alloy.cabal b/alloy.cabal new file mode 100644 --- /dev/null +++ b/alloy.cabal @@ -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 + () and the draft + paper (). +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) + + + + + diff --git a/tutorial/CompanyDatatypes.lhs b/tutorial/CompanyDatatypes.lhs new file mode 100644 --- /dev/null +++ b/tutorial/CompanyDatatypes.lhs @@ -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} + diff --git a/tutorial/Constraints.lhs b/tutorial/Constraints.lhs new file mode 100644 --- /dev/null +++ b/tutorial/Constraints.lhs @@ -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. + diff --git a/tutorial/Effects.lhs b/tutorial/Effects.lhs new file mode 100644 --- /dev/null +++ b/tutorial/Effects.lhs @@ -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}%$ + diff --git a/tutorial/EffectsSelective.lhs b/tutorial/EffectsSelective.lhs new file mode 100644 --- /dev/null +++ b/tutorial/EffectsSelective.lhs @@ -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. diff --git a/tutorial/GenTypes.lhs b/tutorial/GenTypes.lhs new file mode 100644 --- /dev/null +++ b/tutorial/GenTypes.lhs @@ -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). diff --git a/tutorial/GenTypesMapSet.lhs b/tutorial/GenTypesMapSet.lhs new file mode 100644 --- /dev/null +++ b/tutorial/GenTypesMapSet.lhs @@ -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|. diff --git a/tutorial/MapSet.lhs b/tutorial/MapSet.lhs new file mode 100644 --- /dev/null +++ b/tutorial/MapSet.lhs @@ -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} + + diff --git a/tutorial/MapSetExample.lhs b/tutorial/MapSetExample.lhs new file mode 100644 --- /dev/null +++ b/tutorial/MapSetExample.lhs @@ -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). diff --git a/tutorial/Paradise.lhs b/tutorial/Paradise.lhs new file mode 100644 --- /dev/null +++ b/tutorial/Paradise.lhs @@ -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. diff --git a/tutorial/Query.lhs b/tutorial/Query.lhs new file mode 100644 --- /dev/null +++ b/tutorial/Query.lhs @@ -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. + diff --git a/tutorial/Routes.lhs b/tutorial/Routes.lhs new file mode 100644 --- /dev/null +++ b/tutorial/Routes.lhs @@ -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). diff --git a/tutorial/Selective.lhs b/tutorial/Selective.lhs new file mode 100644 --- /dev/null +++ b/tutorial/Selective.lhs @@ -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. diff --git a/tutorial/tutorial.tex b/tutorial/tutorial.tex new file mode 100644 --- /dev/null +++ b/tutorial/tutorial.tex @@ -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}