383 lines
16 KiB
Haskell
383 lines
16 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2008 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | This is the primary module for the polyplate library, that declares the type-class
|
|
-- and methods that use it.
|
|
--
|
|
-- Polyplate is a generic programming system for automatically traversing data
|
|
-- structures, operating on specific types within that structure.
|
|
--
|
|
-- TODO examples
|
|
--
|
|
-- Instances of the PolyplateM type-class /can/ be written manually but it's not
|
|
-- advised. Instead, you should use functions in the "GenInstances" module to automatically
|
|
-- generate source files with the appropriate instances. Instances are generated
|
|
-- for PolyplateMRoute and PolyplateSpine. There is a single instance for each
|
|
-- of PolyplateM and Polyplate that automatically use PolyplateMRoute.
|
|
--
|
|
-- As an example of how to use polyplate we will use the Paradise benchmark, first
|
|
-- used by Ralf Lammel for SYB.
|
|
--
|
|
-- The data-types can be found at: <http://www.cs.vu.nl/boilerplate/testsuite/paradise/CompanyDatatypes.hs>
|
|
--
|
|
-- If you view that file, you can see that the Company type contains all the other
|
|
-- types. So to generate instances you need only do this:
|
|
--
|
|
-- > import CompanyDatatypes
|
|
-- > import Data.Generics.Polyplate.GenInstances
|
|
-- >
|
|
-- > main :: IO ()
|
|
-- > main = writeInstancesTo GenWithoutOverlapped GenOneClass
|
|
-- > [genInstance (undefined :: Company)]
|
|
-- > ["module Instances where"
|
|
-- > ,"import Data.Generics.Polyplate"
|
|
-- > ,"import Data.Generics.Polyplate.Route"
|
|
-- > ,"import Data.Maybe"
|
|
-- > ,"import Data.Tree"
|
|
-- > ,"import qualified CompanyDatatypes"
|
|
-- > ] "Instances.hs"
|
|
--
|
|
-- You must then compile the Instances module in your program, and make sure it
|
|
-- is regenerated every time CompanyDatatypes changes (see the documentation for
|
|
-- your build system).
|
|
--
|
|
-- Then you can write the function to increase salaries as follows (converting
|
|
-- from <http://www.cs.vu.nl/boilerplate/testsuite/paradise/Main.hs>):
|
|
--
|
|
-- > import CompanyDatatypes
|
|
-- > import Data.Generics.Polyplate
|
|
-- > import Data.Generics.Polyplate.Schemes
|
|
-- > 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
|
|
--
|
|
-- As well as doing transformations (both monadic and non-monadic), you can
|
|
-- also perform queries. For this example, we will adapt another SYB example,
|
|
-- that of crushing binary trees
|
|
-- (<http://www.cs.vu.nl/boilerplate/testsuite/foldTree.hs>). This has the
|
|
-- following data types, and example item (here renamed to avoid a conflict):
|
|
--
|
|
-- > data MyTree a w = Leaf a
|
|
-- > | Fork (MyTree a w) (MyTree a w)
|
|
-- > | WithWeight (MyTree a w) w
|
|
-- > deriving (Typeable, Data)
|
|
-- >
|
|
-- > mytree :: MyTree Int Int
|
|
-- > mytree = Fork (WithWeight (Leaf 42) 1)
|
|
-- > (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
|
|
--
|
|
-- The instance generation is identical to before, with the caveat with our
|
|
-- current instance generation, you can only generate instances for concrete
|
|
-- types (e.g. MyTree String Float), not for all parameterised types (e.g. MyTree
|
|
-- String a). The SYB example then prints out two things: first it prints out
|
|
-- all Ints in the tree (thus: both weights and items), and second it prints out
|
|
-- just the values (i.e. Ints wrapped in a Leaf). We can do the same:
|
|
--
|
|
-- > main = print ( catMaybes $ flatten $ applyQuery (id :: Int -> Int) myTree
|
|
-- > , catMaybes $ flatten $ fmap join $ applyQuery fromLeafInt myTree
|
|
-- > )
|
|
-- > where
|
|
-- > fromLeafInt :: MyTree Int Int -> Maybe Int
|
|
-- > fromLeafInt (Leaf x) = Just x
|
|
-- > fromLeafInt _ = Nothing
|
|
--
|
|
-- The 'applyQuery' function takes a query function that transforms items of interest
|
|
-- into query results. In the first case, we simply pass the identity function
|
|
-- on Ints. This will then give us a Tree (Maybe Int) of all the Ints in myTree.
|
|
-- We use flatten to flatten the tree into a list (depth-first ordering) and catMaybes
|
|
-- to filter out any Nothing results. We could also have written this first call
|
|
-- as:
|
|
--
|
|
-- > listifyDepth (const True :: Int -> Bool) myTree
|
|
--
|
|
-- The second call gives Maybe Int as its query result, giving us a Tree (Maybe
|
|
-- (Maybe Int)). We use fmap join to turn this into a Tree (Maybe Int) then catMaybes
|
|
-- and flatten again to get back a list. Another way of writing the second call
|
|
-- would have been:
|
|
--
|
|
-- > [x | Leaf x <- listifyDepth isLeafInt myTree]
|
|
-- > where
|
|
-- > isLeaf :: MyTree Int Int -> Bool
|
|
-- > isLeaf (Leaf _) = True
|
|
-- > isLeaf _ = False
|
|
--
|
|
-- TODO include an example with routes
|
|
module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(..),
|
|
makeRecurseM, RecurseM, makeRecurse, Recurse,
|
|
makeDescendM, DescendM, makeDescend, Descend,
|
|
-- makeRecurseQ, RecurseQ,
|
|
-- makeDescendQ, DescendQ,
|
|
BaseOp, baseOp,
|
|
ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp
|
|
) where
|
|
|
|
import Control.Monad.Identity
|
|
import Data.Maybe
|
|
import Data.Tree
|
|
|
|
import Data.Generics.Polyplate.Route
|
|
|
|
-- | The main Polyplate type-class.
|
|
--
|
|
-- The first parameter is the larger\/outer type on which you want to operate.
|
|
-- If you want to operate on all Strings in a Foo, then the first parameter will
|
|
-- be Foo for the instance you want. The fourth parameter is the monad in which
|
|
-- you wish to perform the transformation. If you do not need a monadic transformation,
|
|
-- see 'transform' and 'Polyplate' below. The fifth parameter is the outermost
|
|
-- type that you began modifying.
|
|
--
|
|
-- The second and third parameters are ops sets. The empty ops list is (), the
|
|
-- unit type. Any other ops set is written as ((a, Route a outer) -> m a, r) where a is the specific
|
|
-- type you are looking to modify, m is the monad (must be the same as the fourth
|
|
-- parameter of the type-class), outer is the same as the fifth parameter of the
|
|
-- type-class, and r is the rest of the ops set (either same
|
|
-- format, or the empty list). Ops sets must never feature functions over a particular
|
|
-- type twice (e.g. ((String, Route String outer) -> m String, ((String, Router
|
|
-- String outer) -> m String, ()))) is not a valid
|
|
-- ops set.
|
|
--
|
|
-- The second parameter is the /recurse/ ops set to apply directly to the
|
|
-- type, whereas the third parameter is the /descent/ ops set to apply to its
|
|
-- children. So for example, if you have a type:
|
|
--
|
|
-- > data Foo = Foo { bar :: Bar, baz :: Baz}
|
|
--
|
|
-- and:
|
|
--
|
|
-- > PolyplateMRoute Foo recurse descent m outer
|
|
--
|
|
-- Then the recurse ops set is the set to apply to Foo, whereas the descent ops
|
|
-- set is the set to apply to Bar and Baz. In particular, if your recurse ops
|
|
-- set is empty and the descent ops set is:
|
|
--
|
|
-- > ((Foo, Route Foo outer) -> m Foo, ())
|
|
--
|
|
-- Then this function will not be applied unless Foo is inside Bar or Baz.
|
|
--
|
|
-- Generally you will not use this function or type-class directly, but will instead
|
|
-- use the helper functions lower down in this module.
|
|
class Monad m => PolyplateMRoute t o o' m outer where
|
|
transformMRoute :: o -> o' -> (t, Route t outer) -> m t
|
|
|
|
-- | A derivative of PolyplateMRoute without all the route stuff.
|
|
--
|
|
-- The first parameter is the larger\/outer type on which you want to operate.
|
|
-- If you want to operate on all Strings in a Foo, then the first parameter will
|
|
-- be Foo for the instance you want. The fourth parameter is the monad in which
|
|
-- you wish to perform the transformation. If you do not need a monadic transformation,
|
|
-- see 'transform' and 'Polyplate' below.
|
|
--
|
|
-- The second and third parameters are ops sets. The empty ops list is (), the
|
|
-- unit type. Any other ops set is written as (a -> m a, r) where a is the specific
|
|
-- type you are looking to modify, m is the monad (must be the same as the fourth
|
|
-- parameter of the type-class), and r is the rest of the ops set (either same
|
|
-- format, or the empty list). Ops sets must never feature functions over a particular
|
|
-- type twice (e.g. (String -> m String, (String -> m String, ()))) is not a valid
|
|
-- ops set.
|
|
--
|
|
-- The second parameter is the /recurse/ ops set to apply directly to the
|
|
-- type, whereas the third parameter is the /descent/ ops set to apply to its
|
|
-- children. So for example, if you have a type:
|
|
--
|
|
-- > data Foo = Foo { bar :: Bar, baz :: Baz}
|
|
--
|
|
-- and:
|
|
--
|
|
-- > PolyplateM Foo recurse descent m
|
|
--
|
|
-- Then the recurse ops set is the set to apply to Foo, whereas the descent ops
|
|
-- set is the set to apply to Bar and Baz. In particular, if your recurse ops
|
|
-- set is empty and the descent ops set is:
|
|
--
|
|
-- > (Foo -> m Foo, ())
|
|
--
|
|
-- Then this function will not be applied unless Foo is inside Bar or Baz.
|
|
--
|
|
-- Generally you will not use this function or type-class directly, but will instead
|
|
-- use the helper functions lower down in this module.
|
|
class (Monad m) => PolyplateM t o o' m where
|
|
transformM :: o -> o' -> t -> m t
|
|
|
|
|
|
instance (Monad m
|
|
, PolyplateMRoute t o o' m ()
|
|
, ConvertOpsToIgnoreRoute ro o
|
|
, ConvertOpsToIgnoreRoute ro' o') => PolyplateM t ro ro' m where
|
|
transformM o o' t = transformMRoute (convertOpsToIgnoreRoute o)
|
|
(convertOpsToIgnoreRoute o')
|
|
(t, fakeRoute t)
|
|
where
|
|
fakeRoute :: t -> Route t ()
|
|
fakeRoute = const $ error "transformM"
|
|
|
|
-- | A non-monadic equivalent of PolyplateM. All ops sets are of the form:
|
|
--
|
|
-- > (a -> a, (b -> b, ()))
|
|
class Polyplate t o o' where
|
|
transform :: o -> o' -> t -> t
|
|
|
|
instance (PolyplateM t mo mo' Identity, ConvertOpsToIdentity o mo, ConvertOpsToIdentity o' mo') => Polyplate t o o' where
|
|
transform o o' t = runIdentity (transformM (convertOpsToIdentity o) (convertOpsToIdentity o') t)
|
|
|
|
-- | A type representing a monadic modifier function that applies the given ops
|
|
-- (opT) in the given monad (m) directly to the given type (t).
|
|
type RecurseM m opT = forall t. PolyplateM t opT () m => t -> m t
|
|
|
|
-- | Given a set of operations (as described in the 'PolyplateM' type-class),
|
|
-- makes a recursive modifier function.
|
|
makeRecurseM :: Monad m => opT -> RecurseM m opT
|
|
makeRecurseM ops = transformM ops ()
|
|
|
|
-- | A type representing a monadic modifier function that applies the given ops
|
|
-- (opT) in the given monad (m) to the children of the given type (t).
|
|
type DescendM m opT = forall t. PolyplateM t () opT m => t -> m t
|
|
|
|
-- | Given a set of operations (as described in the 'PolyplateM' type-class),
|
|
-- makes a descent modifier function that applies the operation to the type's children.
|
|
makeDescendM :: Monad m => opT -> DescendM m opT
|
|
makeDescendM ops = transformM () ops
|
|
|
|
-- | A type representing a modifier function that applies the given ops
|
|
-- (opT) directly to the given type (t).
|
|
type Recurse opT = forall t. Polyplate t opT () => t -> t
|
|
|
|
-- | Given a set of operations (as described in the 'Polyplate' type-class),
|
|
-- makes a modifier function that applies the operations directly.
|
|
makeRecurse :: opT -> Recurse opT
|
|
makeRecurse ops = transform ops ()
|
|
|
|
-- | 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. Polyplate t () opT => t -> t
|
|
|
|
-- | Given a set of operations (as described in the 'PolyplateM' type-class),
|
|
-- makes a descent modifier function that applies the operation to the type's children.
|
|
makeDescend :: opT -> Descend opT
|
|
makeDescend ops = transform () ops
|
|
|
|
{-
|
|
type RecurseQ a opQ = forall t. PolyplateSpine t opQ () a => t -> Tree (Maybe a)
|
|
type DescendQ a opQ = forall t. PolyplateSpine t () opQ a => t -> Tree (Maybe a)
|
|
|
|
|
|
makeRecurseQ :: opQ -> RecurseQ a opQ
|
|
makeRecurseQ ops = transformSpine ops ()
|
|
|
|
makeDescendQ :: opQ -> DescendQ a opQ
|
|
makeDescendQ ops = transformSpine () ops
|
|
-}
|
|
|
|
-- | The type of the empty set of operations
|
|
type BaseOp = ()
|
|
|
|
-- | The function giving you the empty set of operations. Helps to make your
|
|
-- code clearer, even if it's longer.
|
|
baseOp :: BaseOp
|
|
baseOp = ()
|
|
|
|
-- | The type that extends an ops set (opT) in the given monad (m) to be applied to
|
|
-- the given type (t). You cannot mix monadic and non-monadic operations in the
|
|
-- same list. This is for use with the 'PolyplateM' class.
|
|
type ExtOpM m opT t = (t -> m t, opT)
|
|
|
|
-- | The type that extends an ops set (opT) in the given monad (m) to be applied
|
|
-- to the given type (t) with routes to the outer type (outer). This is for use
|
|
-- with the 'PolyplateMRoute' class.
|
|
type ExtOpMRoute m opT t outer = ((t, Route t outer) -> m t, opT)
|
|
|
|
-- | The type that extends an ops set (opT) to be applied to the given type (t).
|
|
-- You cannot mix monadic and non-monadic operations in the same list. This is
|
|
-- for use with the 'Polyplate' class.
|
|
type ExtOp opT t = (t -> t, opT)
|
|
|
|
-- | The function that extends an ops set (opT) in the given monad (m) to be applied to
|
|
-- the given type (t). You cannot mix monadic and non-monadic operations in the
|
|
-- same list. This is for use with the 'PolyplateM' class.
|
|
extOpM :: opT -> (t -> m t) -> ExtOpM m opT t
|
|
extOpM ops f = (f, ops)
|
|
|
|
-- | The function that extends an ops set (opT) in the given monad (m) to be applied
|
|
-- to the given type (t) with routes to the outer type (outer). This is for use
|
|
-- with the 'PolyplateMRoute' class.
|
|
extOpMRoute :: opT -> ((t, Route t outer) -> m t) -> ExtOpMRoute m opT t outer
|
|
extOpMRoute ops f = (f, ops)
|
|
|
|
-- | The function that extends an ops set (opT) in the given monad (m) to be applied to
|
|
-- the given type (t). You cannot mix monadic and non-monadic operations in the
|
|
-- same list. This is for use with the 'Polyplate' class.
|
|
extOp :: opT -> (t -> t) -> ExtOp opT t
|
|
extOp ops f = (f, ops)
|
|
|
|
-- | A handy synonym for a monadic ops set with only one item, to use with 'PolyplateM'.
|
|
type OneOpM m t = ExtOpM m BaseOp t
|
|
-- | A handy synonym for an ops set with only one item, to use with 'Polyplate'.
|
|
type OneOp t = ExtOp BaseOp t
|
|
|
|
-- | A handy synonym for a monadic ops set with only two items, to use with 'PolyplateM'.
|
|
type TwoOpM m s t = ExtOpM m (ExtOpM m BaseOp s) t
|
|
-- | A handy synonym for an ops set with only two items, to use with 'Polyplate'.
|
|
type TwoOp s t = ExtOp (ExtOp BaseOp s) t
|
|
|
|
|
|
-- {{{ Various type-level programming ops conversions:
|
|
|
|
-- | A helper class to convert non-monadic transformations into monadic ones in
|
|
-- the Identity monad.
|
|
class ConvertOpsToIdentity o o' | o -> o' where
|
|
convertOpsToIdentity :: o -> o'
|
|
|
|
instance ConvertOpsToIdentity () () where
|
|
convertOpsToIdentity = id
|
|
|
|
instance ConvertOpsToIdentity r r' => ConvertOpsToIdentity (a -> a, r) (a -> Identity a, r') where
|
|
convertOpsToIdentity (f, r) = (return . f, convertOpsToIdentity r)
|
|
|
|
{-
|
|
-- | A helper class to convert operation lists to have FullSpine at their base
|
|
-- rather than BaseOp
|
|
class ConvertSpineOpsToFull a o o' | a o -> o' where
|
|
convertSpineOpsToFull :: a -> o -> o'
|
|
|
|
instance ConvertSpineOpsToFull a () (FullSpine a) where
|
|
convertSpineOpsToFull def _ = FullSpine def
|
|
|
|
instance ConvertSpineOpsToFull b r r' => ConvertSpineOpsToFull b (a, r) (a, r') where
|
|
convertSpineOpsToFull def (f, r) = (f, convertSpineOpsToFull def r)
|
|
-}
|
|
|
|
-- | A helper class to convert operations not expecting a route to those that ignore
|
|
-- the route (which will have the unit type as its outer type).
|
|
class ConvertOpsToIgnoreRoute o o' | o -> o' where
|
|
convertOpsToIgnoreRoute :: o -> o'
|
|
|
|
instance ConvertOpsToIgnoreRoute () () where
|
|
convertOpsToIgnoreRoute = id
|
|
|
|
instance ConvertOpsToIgnoreRoute r r' =>
|
|
ConvertOpsToIgnoreRoute (t -> m t, r) ((t, Route t ()) -> m t, r') where
|
|
convertOpsToIgnoreRoute (f, r) = (f . fst, convertOpsToIgnoreRoute r)
|
|
|
|
|
|
-- }}}
|