From b94091a08cd8cccc5f363418a7933fbe4cf0a8fc Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sun, 14 Dec 2008 22:47:07 +0000 Subject: [PATCH] Moved all of the Route stuff out into a new polyplate module --- Makefile.am | 1 + checks/CheckFramework.hs | 5 +- common/GenericUtils.hs | 117 ++--------------- flow/FlowGraph.hs | 5 +- polyplate/Data/Generics/Polyplate/Route.hs | 139 +++++++++++++++++++++ 5 files changed, 156 insertions(+), 111 deletions(-) create mode 100644 polyplate/Data/Generics/Polyplate/Route.hs diff --git a/Makefile.am b/Makefile.am index 106a83b..84041a2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -194,6 +194,7 @@ tock_SOURCES_hs += pass/PassList.hs tock_SOURCES_hs += pass/Properties.hs tock_SOURCES_hs += pass/Traversal.hs tock_SOURCES_hs += polyplate/Data/Generics/Polyplate.hs +tock_SOURCES_hs += polyplate/Data/Generics/Polyplate/Route.hs tock_SOURCES_hs += polyplate/Data/Generics/Polyplate/Schemes.hs tock_SOURCES_hs += transformations/ImplicitMobility.hs tock_SOURCES_hs += transformations/SimplifyAbbrevs.hs diff --git a/checks/CheckFramework.hs b/checks/CheckFramework.hs index 0dc251a..f829f21 100644 --- a/checks/CheckFramework.hs +++ b/checks/CheckFramework.hs @@ -35,6 +35,7 @@ import GHC.Base (unsafeCoerce#) import qualified AST as A import CompState +import Data.Generics.Polyplate.Route import Errors import FlowAlgorithms import FlowGraph @@ -485,8 +486,8 @@ withChild :: forall acc t a. [Int] -> CheckOptASTM' acc t a -> CheckOptASTM' acc withChild ns (CheckOptASTM' m) = askRoute >>= (CheckOptASTM' . lift . inner) where inner :: Route t A.AST -> RestartT CheckOptM (Either t a) - inner (Route rId rFunc) = runReaderT m (error "withChild asked for accum", - Route (rId ++ ns) (error "withChild attempted a substitution")) + inner r = runReaderT m (error "withChild asked for accum", + makeRoute (routeId r) (error "withChild attempted a substitution")) -- | Searches forward in the graph from the given node to find all the reachable -- nodes that have no successors, i.e. the terminal nodes diff --git a/common/GenericUtils.hs b/common/GenericUtils.hs index a35f01a..edf8760 100644 --- a/common/GenericUtils.hs +++ b/common/GenericUtils.hs @@ -44,6 +44,7 @@ import Data.Typeable import System.IO.Unsafe import qualified AST as A +import Data.Generics.Polyplate.Route import TreeUtils import Utils @@ -160,102 +161,6 @@ gmapMFor typeset f = gmapM (each f) Just Miss -> return x Nothing -> return x --- | 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. --- --- To do this you can use: --- --- > myRoute :: Route Int (BinTree Int) --- --- You apply it as follows (for example, to increment the integer): --- --- > runIdentity $ routeModify myRoute (return . (+1)) myTree --- --- The modifier is monadic because that's usually how we want to use it, but we --- can use the identity monad as above for pure functions. This will only work --- if the route is valid on the given tree. --- --- 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 (in my opinion) easier to use, and --- tack on to existing code with complex data structures (without needing any code --- generation). You can either compose routes yourself (as the flow-graph building --- does) or by using 'gmapMForRoute'. --- --- 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 first 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: --- --- > runIdentity $ routeModify (routeList 3) (return . (*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 >>* (: xs)) -routeList n = Route [1] (\f (x:xs) -> f xs >>* (x:)) @-> routeList (n-1) - --- | Applies a monadic modification function using the given route. -routeModify :: Monad m => Route inner outer -> (inner -> m inner) -> (outer -> m - outer) -routeModify (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 . routeModify 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 = runIdentity . routeModify route (const $ return 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 routeIdentity == id --- > routeSet routeIdentity == const --- > routeModify routeIdentity == id --- > routeIdentity @-> route == route --- > route @-> routeIdentity == route -routeIdentity :: Route a a -routeIdentity = Route [] id -- | Acts just like gmapMFor, except that it also tells you the route to the node -- that your generic function is being applied to. @@ -280,11 +185,11 @@ gmapMWithRoute :: forall a m. (Monad m, Data a) => (forall b. Data b => (b, Rout gmapMWithRoute f = gmapFuncs [GM {unGM = f' n} | n <- [0..]] where f' :: Int -> (forall b. Data b => b -> m b) - f' n x = f (x, makeRoute n) + f' n x = f (x, makeRoute' n) -- Given a number, makes a route function for that child: -makeRoute :: (Data s, Data t) => Int -> Route s t -makeRoute target = Route [target] (\f -> gmapFuncs [mkM' (if n == target then f else return) | n <- [0..]]) +makeRoute' :: (Data s, Data t) => Int -> Route s t +makeRoute' target = makeRoute [target] (\f -> gmapFuncs [mkM' (if n == target then f else return) | n <- [0..]]) decomp11 :: (Monad m, Data a, Typeable a0) => (a0 -> a) -> (a0 -> m a0) -> (a -> m a) decomp11 con f1 = decomp1 con f1 @@ -318,29 +223,29 @@ route11 :: (Data a, Typeable a0) => Route a b -> (a0 -> a) -> Route a0 b route11 route con = route @-> Route [0] (decomp11 con) route22 :: (Data a, Typeable a0, Typeable a1) => Route a b -> (a0 -> a1 -> a) -> Route a1 b -route22 route con = route @-> Route [1] (decomp22 con) +route22 route con = route @-> makeRoute [1] (decomp22 con) route23 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a1 b -route23 route con = route @-> Route [1] (decomp23 con) +route23 route con = route @-> makeRoute [1] (decomp23 con) route33 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a2 b -route33 route con = route @-> Route [2] (decomp33 con) +route33 route con = route @-> makeRoute [2] (decomp33 con) route34 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) => Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a2 b -route34 route con = route @-> Route [2] (decomp34 con) +route34 route con = route @-> makeRoute [2] (decomp34 con) route44 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) => Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a3 b -route44 route con = route @-> Route [3] (decomp44 con) +route44 route con = route @-> makeRoute [3] (decomp44 con) route45 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) => Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a3 b -route45 route con = route @-> Route [3] (decomp45 con) +route45 route con = route @-> makeRoute [3] (decomp45 con) route55 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) => Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a4 b -route55 route con = route @-> Route [4] (decomp55 con) +route55 route con = route @-> makeRoute [4] (decomp55 con) -- TODO we should be able to provide versions of these that do not need to know -- the constructor or the arity diff --git a/flow/FlowGraph.hs b/flow/FlowGraph.hs index 8e50150..a930128 100644 --- a/flow/FlowGraph.hs +++ b/flow/FlowGraph.hs @@ -51,7 +51,6 @@ import Data.Graph.Inductive hiding (run) import Data.Maybe import qualified AST as A -import CompState import GenericUtils import Metadata import FlowUtils @@ -76,9 +75,9 @@ buildProcessOrFunctionSpec (A.Specification _ _ (A.Proc m _ args (Just p))) rout buildProcessOrFunctionSpec (A.Specification _ _ (A.Function m _ _ args (Just es))) route = let funcRoute = (route33 route A.Specification) in case es of - Left sel -> addNewSubProcFunc m args (Right (sel, route55 funcRoute A.Function @-> (Route + Left sel -> addNewSubProcFunc m args (Right (sel, route55 funcRoute A.Function @-> (makeRoute [0,0] $ \f (Just (Left e)) -> f e >>* (Just . Left)))) (route45 funcRoute A.Function) - Right p -> addNewSubProcFunc m args (Left (p, route55 funcRoute A.Function @-> (Route + Right p -> addNewSubProcFunc m args (Left (p, route55 funcRoute A.Function @-> (makeRoute [0,0] $ \f (Just (Right p)) -> f p >>* (Just . Right)))) (route45 funcRoute A.Function) buildProcessOrFunctionSpec _ _ = return () diff --git a/polyplate/Data/Generics/Polyplate/Route.hs b/polyplate/Data/Generics/Polyplate/Route.hs new file mode 100644 index 0000000..fd731eb --- /dev/null +++ b/polyplate/Data/Generics/Polyplate/Route.hs @@ -0,0 +1,139 @@ +{- +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 . +-} +module Data.Generics.Polyplate.Route + (routeModify, routeGet, routeSet, Route, (@->), routeIdentity, routeId, routeList, + makeRoute, routeDataMap, routeDataSet) + where + +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. +-- +-- To do this you can use: +-- +-- > myRoute :: Route Int (BinTree Int) +-- +-- You apply it as follows (for example, to increment the integer): +-- +-- > runIdentity $ routeModify myRoute (return . (+1)) myTree +-- +-- The modifier is monadic because that's usually how we want to use it, but we +-- can use the identity monad as above for pure functions. This will only work +-- if the route is valid on the given tree. +-- +-- 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 (in my opinion) easier to use, and +-- tack on to existing code with complex data structures (without needing any code +-- generation). You can either compose routes yourself (as the flow-graph building +-- does) or by using 'gmapMForRoute'. +-- +-- 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 first 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: +-- +-- > runIdentity $ routeModify (routeList 3) (return . (*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) + +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)) + +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 monadic modification function using the given route. +routeModify :: Monad m => Route inner outer -> (inner -> m inner) -> (outer -> m + outer) +routeModify (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 . routeModify 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 = runIdentity . routeModify route (const $ return 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 routeIdentity == id +-- > routeSet routeIdentity == const +-- > routeModify routeIdentity == id +-- > routeIdentity @-> route == route +-- > route @-> routeIdentity == route +routeIdentity :: Route a a +routeIdentity = Route [] id + +makeRoute :: [Int] -> (forall m. Monad m => (inner -> m inner) -> (outer -> m outer)) + -> Route inner outer +makeRoute = Route