Moved all of the Route stuff out into a new polyplate module

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

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",
+    inner r = runReaderT m (error "withChild asked for accum",
-      Route (rId ++ ns) (error "withChild attempted a substitution"))
+      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

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' :: (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' 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

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 ()
 

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 <http://www.gnu.org/licenses/>.
+-}
+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