suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Neil Brown 2008-12-14 22:47:07 +00:00
parent ccb6c7aa1d
commit b94091a08c
5 changed files with 156 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -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

5
checks/CheckFramework.hs
View File

@ -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

117
common/GenericUtils.hs
View File

@ -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

5
flow/FlowGraph.hs
View File

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

139
polyplate/Data/Generics/Polyplate/Route.hs Normal file
View File

@ -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