From 853a52cc002aac04d63f218f41c1c969b98d5610 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Mon, 11 May 2009 15:22:58 +0000 Subject: [PATCH] Finished the name change from Polyplate to Alloy Most of this was a find-and-replace, PolyplateM -> AlloyA. But I also fixed some of the opsets and removed types that were no longer needed, and so on. --- alloy/Data/Generics/Alloy.hs | 210 +++++++++------------- alloy/Data/Generics/Alloy/GenInstances.hs | 72 ++++---- alloy/Data/Generics/Alloy/Route.hs | 2 +- alloy/Data/Generics/Alloy/Schemes.hs | 101 +++++------ backends/BackendPasses.hs | 12 +- checks/ArrayUsageCheck.hs | 2 +- checks/Check.hs | 8 +- checks/CheckFramework.hs | 109 ++++++----- checks/UsageCheckUtils.hs | 2 +- flow/FlowGraph.hs | 2 +- flow/FlowGraphTest.hs | 2 +- flow/FlowUtils.hs | 2 +- frontends/OccamCheckTypes.hs | 16 +- frontends/OccamInferTypes.hs | 74 ++++---- frontends/OccamPasses.hs | 5 +- frontends/OccamPassesTest.hs | 12 +- frontends/OccamTypesTest.hs | 32 ++-- frontends/RainTypes.hs | 20 +-- pass/Pass.hs | 20 +-- pass/Traversal.hs | 136 ++++++++------ pregen/GenNavAST.hs | 6 +- transformations/ImplicitMobility.hs | 4 +- transformations/SimplifyAbbrevs.hs | 21 ++- transformations/SimplifyAbbrevsTest.hs | 6 +- transformations/SimplifyExprs.hs | 34 ++-- transformations/SimplifyProcs.hs | 7 +- transformations/SimplifyTypesTest.hs | 4 +- transformations/Unnest.hs | 38 ++-- 28 files changed, 464 insertions(+), 495 deletions(-) diff --git a/alloy/Data/Generics/Alloy.hs b/alloy/Data/Generics/Alloy.hs index 57dbc17..5b52961 100644 --- a/alloy/Data/Generics/Alloy.hs +++ b/alloy/Data/Generics/Alloy.hs @@ -16,21 +16,21 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . -} --- | This is the primary module for the polyplate library, that declares the type-class +-- | This is the primary module for the alloy library, that declares the type-class -- and methods that use it. -- --- Polyplate is a generic programming system for automatically traversing data +-- Alloy 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 +-- Instances of the AlloyA 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. +-- for AlloyARoute and AlloySpine. There is a single instance for each +-- of AlloyA and Alloy that automatically use AlloyARoute. -- --- As an example of how to use polyplate we will use the Paradise benchmark, first +-- As an example of how to use alloy we will use the Paradise benchmark, first -- used by Ralf Lammel for SYB. -- -- The data-types can be found at: @@ -39,14 +39,14 @@ with this program. If not, see . -- types. So to generate instances you need only do this: -- -- > import CompanyDatatypes --- > import Data.Generics.Polyplate.GenInstances +-- > import Data.Generics.Alloy.GenInstances -- > -- > main :: IO () -- > main = writeInstancesTo GenWithoutOverlapped GenOneClass -- > [genInstance (undefined :: Company)] -- > ["module Instances where" --- > ,"import Data.Generics.Polyplate" --- > ,"import Data.Generics.Polyplate.Route" +-- > ,"import Data.Generics.Alloy" +-- > ,"import Data.Generics.Alloy.Route" -- > ,"import Data.Maybe" -- > ,"import Data.Tree" -- > ,"import qualified CompanyDatatypes" @@ -60,8 +60,8 @@ with this program. If not, see . -- from ): -- -- > import CompanyDatatypes --- > import Data.Generics.Polyplate --- > import Data.Generics.Polyplate.Schemes +-- > import Data.Generics.Alloy +-- > import Data.Generics.Alloy.Schemes -- > import Instances -- > -- > increase :: Float -> Company -> Company @@ -123,14 +123,14 @@ with this program. If not, see . -- > isLeaf _ = False -- -- TODO include an example with routes -module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(..), - makeRecurseM, RecurseM, makeRecurse, Recurse, - makeDescendM, DescendM, makeDescend, Descend, +module Data.Generics.Alloy (AlloyARoute(..), AlloyA(..), Alloy(..), + makeRecurseA, makeRecurseM, RecurseA, makeRecurse, Recurse, + makeDescendA, makeDescendM, DescendA, makeDescend, Descend, -- makeRecurseQ, RecurseQ, -- makeDescendQ, DescendQ, - BaseOp(..), BaseOpM(..), BaseOpMRoute(..), baseOp, baseOpM, baseOpM', baseOpMRoute, + BaseOp(..), BaseOpA(..), BaseOpARoute(..), baseOp, baseOpA, baseOpARoute, (:-)(..), (:-*)(..), (:-@)(..), - ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpMRoute, OneOpM, OneOp, TwoOpM, TwoOp + OneOpARoute, OneOpA, OneOp, TwoOpA, TwoOp ) where import Control.Applicative @@ -138,15 +138,15 @@ import Control.Monad.Identity import Data.Maybe import Data.Tree -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy.Route --- | The main Polyplate type-class. +-- | The main Alloy 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 +-- see 'transform' and 'Alloy' 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 @@ -167,7 +167,7 @@ import Data.Generics.Polyplate.Route -- -- and: -- --- > PolyplateMRoute Foo recurse descent m outer +-- > AlloyARoute 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 @@ -179,17 +179,17 @@ import Data.Generics.Polyplate.Route -- -- Generally you will not use this function or type-class directly, but will instead -- use the helper functions lower down in this module. -class PolyplateMRoute t o o' where +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 --- | A derivative of PolyplateMRoute without all the route stuff. +-- | A derivative of AlloyARoute 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. +-- see 'transform' and 'Alloy' 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 @@ -207,7 +207,7 @@ class PolyplateMRoute t o o' where -- -- and: -- --- > PolyplateM Foo recurse descent m +-- > AlloyA 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 @@ -219,14 +219,14 @@ class PolyplateMRoute t o o' where -- -- Generally you will not use this function or type-class directly, but will instead -- use the helper functions lower down in this module. -class PolyplateM t o o' where +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 instance ( - PolyplateMRoute t o o' + AlloyARoute t o o' , ConvertOpsToIgnoreRoute ro o - , ConvertOpsToIgnoreRoute ro' o') => PolyplateM t ro ro' where + , ConvertOpsToIgnoreRoute ro' o') => AlloyA t ro ro' where transformM o o' t = transformMRoute (convertOpsToIgnoreRoute o) (convertOpsToIgnoreRoute o') (t, fakeRoute t) @@ -240,139 +240,113 @@ instance ( fakeRoute :: t -> Route t () fakeRoute = const $ error "transformA" --- | A non-monadic equivalent of PolyplateM. All ops sets are of the form: +-- | A non-monadic equivalent of AlloyA. All ops sets are of the form: -- -- > (a -> a, (b -> b, ())) -class Polyplate t o o' where +class Alloy t o o' where transform :: o -> o' -> t -> t -instance (PolyplateM t mo mo', ConvertOpsToIdentity o mo, ConvertOpsToIdentity o' mo') => Polyplate t o o' where +instance (AlloyA t mo mo', ConvertOpsToIdentity o mo, ConvertOpsToIdentity o' mo') => Alloy 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 BaseOpM => t -> m t +type RecurseA f opT = forall t. AlloyA t opT BaseOpA => t -> f t --- | Given a set of operations (as described in the 'PolyplateM' type-class), +-- | Given a set of operations (as described in the 'AlloyA' type-class), -- makes a recursive modifier function. -makeRecurseM :: Monad m => opT m -> RecurseM m opT -makeRecurseM ops = transformM ops baseOpM +makeRecurseA :: Applicative f => opT f -> RecurseA f opT +makeRecurseA ops = transformA ops baseOpA + +-- | Given a set of operations (as described in the 'AlloyA' type-class), +-- makes a recursive modifier function. +makeRecurseM :: Monad m => opT m -> RecurseA m opT +makeRecurseM ops = transformM ops baseOpA -- | 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 BaseOpM opT => t -> m t +type DescendA f opT = forall t. AlloyA t BaseOpA opT => t -> f t --- | Given a set of operations (as described in the 'PolyplateM' type-class), +-- | Given a set of operations (as described in the 'AlloyA' type-class), -- makes a descent modifier function that applies the operation to the type's children. -makeDescendM :: Monad m => opT m -> DescendM m opT -makeDescendM ops = transformM baseOpM ops +makeDescendA :: Applicative f => opT f -> DescendA f opT +makeDescendA ops = transformA baseOpA ops + +-- | Given a set of operations (as described in the 'AlloyA' type-class), +-- makes a descent modifier function that applies the operation to the type's children. +makeDescendM :: Monad m => opT m -> DescendA m opT +makeDescendM ops = transformM baseOpA 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 BaseOp => t -> t +type Recurse opT = forall t. Alloy t opT BaseOp => t -> t --- | Given a set of operations (as described in the 'Polyplate' type-class), +-- | Given a set of operations (as described in the 'Alloy' type-class), -- makes a modifier function that applies the operations directly. 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. Polyplate t BaseOp opT => t -> t +type Descend opT = forall t. Alloy t BaseOp opT => t -> t --- | Given a set of operations (as described in the 'PolyplateM' type-class), +-- | Given a set of operations (as described in the 'AlloyA' type-class), -- makes a descent modifier function that applies the operation to the type's children. makeDescend :: opT -> Descend opT makeDescend ops = transform baseOp 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 = () +data BaseOp = BaseOp -- | The function giving you the empty set of operations. Helps to make your -- code clearer, even if it's longer. baseOp :: BaseOp -baseOp = () +baseOp = BaseOp -baseOpM :: BaseOpM m -baseOpM = BaseOpM +baseOpA :: BaseOpA m +baseOpA = BaseOpA -baseOpM' :: (a -> m a) -> BaseOpM m -baseOpM' = const BaseOpM - -baseOpMRoute :: BaseOpMRoute m outer -baseOpMRoute = BaseOpMRoute +baseOpARoute :: BaseOpARoute m outer +baseOpARoute = BaseOpARoute -- | 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. +-- same list. This is for use with the 'AlloyA' class. --data ((t :: *) :-* (opT :: (* -> *) -> *)) m = (t -> m t) :-* (opT m) data (t :-* opT) m = (t -> m t) :-* (opT m) ---data E t (opT :: (* -> *) -> *) m = (:-*) (t -> m t) (opT m) infixr 7 :-* -type ExtOpM m opT t = (t :-* opT) m - -data BaseOpM m = BaseOpM - -data (t :-@ opT) m outer = ((t, Route t outer) -> m t) :-@ (opT m outer) - -data BaseOpMRoute m outer = BaseOpMRoute +data BaseOpA m = BaseOpA -- | 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 :-@ opT) m outer ---((t, Route t outer) -> m t, opT) +-- with the 'AlloyARoute' class. +data (t :-@ opT) m outer = ((t, Route t outer) -> m t) :-@ (opT m outer) + +infixr 7 :-@ + +data BaseOpARoute m outer = BaseOpARoute + -- | 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. +-- for use with the 'Alloy' class. data t :- opT = (t -> t) :- opT -type ExtOp opT t = t :- opT +infixr 7 :- --- | 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 m -> (t -> m t) -> ExtOpM m opT t -extOpM ops f = f :-* ops +-- | A handy synonym for a monadic ops set with only one item, to use with 'AlloyARoute'. +type OneOpARoute t = t :-@ BaseOpARoute +-- | A handy synonym for a monadic ops set with only one item, to use with 'AlloyA'. +type OneOpA t = t :-* BaseOpA +-- | A handy synonym for an ops set with only one item, to use with 'Alloy'. +type OneOp t = t :- BaseOp --- | 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 m outer -> ((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 'PolyplateMRoute'. -type OneOpMRoute t = t :-@ BaseOpMRoute --- | A handy synonym for a monadic ops set with only one item, to use with 'PolyplateM'. -type OneOpM t = t :-* BaseOpM --- | 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 s t = (s :-* t :-* BaseOpM) --ExtOpM m (ExtOpM m BaseOpM 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 +-- | A handy synonym for a monadic ops set with only two items, to use with 'AlloyA'. +type TwoOpA s t = (s :-* t :-* BaseOpA) --ExtOpM m (ExtOpM m BaseOpA s) t +-- | A handy synonym for an ops set with only two items, to use with 'Alloy'. +type TwoOp s t = s :- t :- BaseOp -- {{{ Various type-level programming ops conversions: @@ -382,40 +356,22 @@ type TwoOp s t = ExtOp (ExtOp BaseOp s) t class ConvertOpsToIdentity o o' | o -> o' where convertOpsToIdentity :: o -> o' Identity -instance ConvertOpsToIdentity BaseOp BaseOpM where - convertOpsToIdentity = const baseOpM +instance ConvertOpsToIdentity BaseOp BaseOpA where + convertOpsToIdentity = const baseOpA instance ConvertOpsToIdentity r r' => ConvertOpsToIdentity (a :- r) (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 m -> o' m () -instance ConvertOpsToIgnoreRoute BaseOpM BaseOpMRoute where - convertOpsToIgnoreRoute = const baseOpMRoute +instance ConvertOpsToIgnoreRoute BaseOpA BaseOpARoute where + convertOpsToIgnoreRoute = const baseOpARoute instance ConvertOpsToIgnoreRoute r r' => ConvertOpsToIgnoreRoute (t :-* r) (t :-@ r') where convertOpsToIgnoreRoute (f :-* r) = (f . fst) :-@ (convertOpsToIgnoreRoute r) -{- -instance ConvertOpsToIgnoreRoute (r m) (r' m ()) => - ConvertOpsToIgnoreRoute ((t :-* r) m) ((t :-@ r') m ()) where - convertOpsToIgnoreRoute (f :-* r) = (f . fst) :-@ (convertOpsToIgnoreRoute r) --} -- }}} diff --git a/alloy/Data/Generics/Alloy/GenInstances.hs b/alloy/Data/Generics/Alloy/GenInstances.hs index 6a23cdb..38d7f74 100644 --- a/alloy/Data/Generics/Alloy/GenInstances.hs +++ b/alloy/Data/Generics/Alloy/GenInstances.hs @@ -35,7 +35,7 @@ with this program. If not, see . -- -- > deriving instance Typeable Foo -- > deriving instance Data Foo -module Data.Generics.Polyplate.GenInstances +module Data.Generics.Alloy.GenInstances (GenOverlappedOption(..), GenClassOption(..), GenInstance, genInstance, genMapInstance, genSetInstance, genInstances, writeInstances, writeInstancesTo) where @@ -58,7 +58,7 @@ data GenOverlappedOption = GenWithOverlapped | GenWithoutOverlapped deriving (Eq) -- | The option controlling whether the generated instances have one class per --- type, or just generate instances of the primary Polyplate class. Having one +-- type, or just generate instances of the primary Alloy class. Having one -- class per type compiles faster on GHC, but can give less clear error messages -- due to the name munging that goes on. data GenClassOption @@ -142,7 +142,7 @@ genMapInstance k v (\(funcSameType, funcNewType) -> concat [ [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 BaseOpMRoute) mns)" + ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpARoute) mns)" ] | b <- [True, False]]) )) @@ -163,7 +163,7 @@ genSetInstance x (\(funcSameType, funcNewType) -> concat [ [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 BaseOpMRoute) sns)" + ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpARoute) sns)" ] | b <- [True, False]]) )) @@ -172,9 +172,9 @@ genSetInstance x s = undefined --- Explanation of Polyplate's instances: +-- Explanation of Alloy's instances: -- --- Polyplate is a type-class system for automatically applying generic transformations +-- 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. @@ -183,7 +183,7 @@ genSetInstance x -- -- The unit type is the list terminator. -- --- The Polyplate class takes four parameters: +-- The Alloy class takes four parameters: -- -- * The first is the type currently being processed. -- @@ -198,7 +198,7 @@ genSetInstance x -- -- * The "exact match" instance. These are of the form: -- --- > instance Monad m => PolyplateM a (a -> m a, r) ops m where +-- > 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 @@ -211,10 +211,10 @@ genSetInstance x -- This is of the form: -- -- > instance (Monad m, --- > PolyplateM Bar (f,ops) () m, --- > PolyplateM Baz (f,ops) () m, --- > PolyplateM Quux (f,ops) () m) => --- > PolyplateM Foo () (f, ops) m where +-- > 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) @@ -234,8 +234,8 @@ genSetInstance x -- -- * The "can contain" instance. This is of the form: -- --- > instance (Monad m, PolyplateM t r (a -> m a, ops) m) => --- > PolyplateM t (a -> m a, r) ops m where +-- > 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 @@ -245,8 +245,8 @@ genSetInstance x -- -- * The "cannot contain" instance. This is of the form: -- --- > instance (Monad m, PolyplateM t r ops m) => --- > PolyplateM t (a -> m a, r) ops m where +-- > 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 @@ -262,7 +262,7 @@ genSetInstance x -- | Instances for a particular data type (i.e. where that data type is the --- first argument to 'Polyplate'). +-- first argument to 'Alloy'). instancesFrom :: forall t. Data t => GenOverlappedOption -> GenClassOption -> [Witness] -> t -> IO [String] instancesFrom genOverlapped genClass boxes w = do (specialProcessChildren, containedTypes) <- @@ -302,11 +302,11 @@ instancesFrom genOverlapped genClass boxes w -- 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 PolyplateM. + -- For GenOneClass this will be an instance of AlloyA. -- - -- For GenClassPerType this will be an instance of PolyplateMFoo (or whatever) + -- For GenClassPerType this will be an instance of AlloyAFoo (or whatever) -- - -- For GenSlowDelegate this will be an instance of PolyplateM', with the first + -- 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 @@ -318,17 +318,17 @@ instancesFrom genOverlapped genClass boxes w -- sets. The class name will be the same as genInst. contextSameType :: String -> String -> String contextSameType ops0 ops1 = case genClass of - GenOneClass -> "PolyplateMRoute (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 - GenClassPerType -> "PolyplateMRoute" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1 - GenSlowDelegate -> "PolyplateMRoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")" + GenOneClass -> "AlloyARoute (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 + GenClassPerType -> "AlloyARoute" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1 + GenSlowDelegate -> "AlloyARoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")" -- Generates the name of an instance for a different type (for processing children). - -- This will be PolyplateM or PolyplateM'. + -- This will be AlloyA or AlloyA'. contextNewType :: String -> String -> String -> String contextNewType cName ops0 ops1 = case genClass of - GenOneClass -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 - GenClassPerType -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 - GenSlowDelegate -> "PolyplateMRoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")" + GenOneClass -> "AlloyARoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 + GenClassPerType -> "AlloyARoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 + GenSlowDelegate -> "AlloyARoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")" -- The function to define in the body, and also to use for processing the same @@ -356,7 +356,7 @@ instancesFrom genOverlapped genClass boxes w baseInst :: Maybe ([DataBox], (Bool -> String, Bool -> String) -> [String]) -> [String] baseInst mdoChildren = concat - [genInst context "BaseOpMRoute" "(f :-@ ops)" $ + [genInst context "BaseOpARoute" "(f :-@ ops)" $ maybe (concat [if isAlgType wDType @@ -366,7 +366,7 @@ instancesFrom genOverlapped genClass boxes w else [funcSameType b ++ " _ _ (v, _) = " ++ funcPlain b ++ " v"] | b <- [True, False]]) (\(_,f) -> f (funcSameType, funcNewType)) mdoChildren - ,genInst [] "BaseOpMRoute" "BaseOpMRoute" + ,genInst [] "BaseOpARoute" "BaseOpARoute" [funcSameType b ++ " _ _ (v, _) = " ++ funcPlain b ++ " v" | b <- [True, False]] ,if genOverlapped == GenWithoutOverlapped then [] else genInst @@ -375,14 +375,14 @@ instancesFrom genOverlapped genClass boxes w [funcSameType b ++ " (_ :-@ rest) ops vr = " ++ funcSameType b ++ " rest ops vr" | b <- [True, False]] ,if genClass == GenClassPerType - then ["class PolyplateMRoute" ++ wMunged ++ " o o' where" + then ["class AlloyARoute" ++ wMunged ++ " o o' where" ," " ++ funcSameType True ++ " :: Monad m => o m outer -> o' m outer -> (" ++ wName ++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")" ," " ++ funcSameType False ++ " :: Applicative a => o a outer -> o' a outer -> (" ++ wName ++ ", Route (" ++ wName ++ ") outer) -> a (" ++ wName ++ ")" ,"" ,"instance (" ++ contextSameType "o0" "o1" ++ ") =>" - ," PolyplateMRoute (" ++ wName ++ ") o0 o1 where" + ," AlloyARoute (" ++ wName ++ ") o0 o1 where" ," transformMRoute = " ++ funcSameType True ," transformARoute = " ++ funcSameType False ] @@ -390,11 +390,11 @@ instancesFrom genOverlapped genClass boxes w ] where -- | Class context for 'baseInst'. - -- We need an instance of Polyplate for each of the types directly contained within + -- 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 :-@ ops)" "BaseOpMRoute" + = [ contextNewType argType "(f :-@ ops)" "BaseOpARoute" | argType <- nub $ sort $ concatMap ctrArgTypes $ maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren] @@ -407,7 +407,7 @@ instancesFrom genOverlapped genClass boxes w " (" ++ ctrInput ++ " , " ++ (if argNums == [] then "_" else "rt") ++ ")" , " = " ++ funcPlain b ++ " " ++ ctrName ] ++ - [ " " ++ funcAp b ++ " (" ++ funcNewType b ++ " ops BaseOpMRoute (a" ++ show i + [ " " ++ funcAp b ++ " (" ++ funcNewType b ++ " ops BaseOpARoute (a" ++ show i ++ ", rt @-> makeRoute [" ++ show i ++ "] " ++ "(\\f (" ++ ctrMod ++ ") -> f b" ++ show i ++ " >>= (\\b" ++ show i ++ " -> return (" ++ ctrMod ++ ")))))" @@ -455,8 +455,8 @@ instancesFrom genOverlapped genClass boxes w | otherwise = (False,[],[]) -- | Generates all the given instances (eliminating any duplicates) --- with the given options. The return is a pair of a list of instances of PolyplateMRoute, --- and a list of instances of PolyplateSpine +-- with the given options. The return is a pair of a list of instances of AlloyARoute, +-- and a list of instances of AlloySpine genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> IO [String] genInstances op1 op2 insts diff --git a/alloy/Data/Generics/Alloy/Route.hs b/alloy/Data/Generics/Alloy/Route.hs index 68ca2ea..f21260e 100644 --- a/alloy/Data/Generics/Alloy/Route.hs +++ b/alloy/Data/Generics/Alloy/Route.hs @@ -15,7 +15,7 @@ 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 +module Data.Generics.Alloy.Route (Route, routeModify, routeGet, routeSet, (@->), identityRoute, routeId, routeList, makeRoute, routeDataMap, routeDataSet) where diff --git a/alloy/Data/Generics/Alloy/Schemes.hs b/alloy/Data/Generics/Alloy/Schemes.hs index ceb6eb5..0706f05 100644 --- a/alloy/Data/Generics/Alloy/Schemes.hs +++ b/alloy/Data/Generics/Alloy/Schemes.hs @@ -17,12 +17,12 @@ with this program. If not, see . -} -module Data.Generics.Polyplate.Schemes where +module Data.Generics.Alloy.Schemes where import Control.Monad.State -import Data.Generics.Polyplate -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy +import Data.Generics.Alloy.Route -- * Adding traversal to modifiers @@ -30,51 +30,51 @@ import Data.Generics.Polyplate.Route -- 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 'applyBottomUp'). -makeBottomUp :: Polyplate t BaseOp opT => opT -> (t -> t) -> t -> t +makeBottomUp :: Alloy t BaseOp opT => opT -> (t -> t) -> t -> t makeBottomUp ops f v = f (makeDescend ops v) -- | Given a list of operations and a monadic 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 'applyBottomUpM'). -makeBottomUpM :: (PolyplateM t BaseOpM opT, Monad m) => opT m -> (t -> m t) -> t -> m t +makeBottomUpM :: (AlloyA t BaseOpA opT, Monad m) => opT m -> (t -> m t) -> t -> m t makeBottomUpM ops f v = makeDescendM ops v >>= f -- | As makeBottomUpM, but with routes as well. -makeBottomUpMRoute :: forall m opT t outer. (Monad m, PolyplateMRoute t BaseOpMRoute opT) => +makeBottomUpMRoute :: forall m opT t outer. (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 base ops (v, r) f (v', r) where - base :: BaseOpMRoute m outer - base = baseOpMRoute + base :: BaseOpARoute m outer + base = baseOpARoute -- | Given a list of operations and a modifier function, augments that modifier -- function to first apply the modifier function before then descending into the value. -- This can be used to perform a top-down depth-first traversal of a structure -- (see 'applyTopDown'). -makeTopDown :: Polyplate t () opT => opT -> (t -> t) -> t -> t +makeTopDown :: Alloy t BaseOp opT => opT -> (t -> t) -> t -> t makeTopDown ops f v = makeDescend ops (f v) -- | Given a list of operations and a monadic modifier function, augments that modifier -- function to first apply the modifier function before then descending into the value. -- This can be used to perform a top-down depth-first traversal of a structure -- (see 'applyTopDownM'). -makeTopDownM :: (PolyplateM t BaseOpM opT, Monad m) => opT m -> (t -> m t) -> t -> m t +makeTopDownM :: (AlloyA t BaseOpA opT, Monad m) => opT m -> (t -> m t) -> t -> m t makeTopDownM ops f v = f v >>= makeDescendM ops -- | As makeTopDownM, but with routes as well. -makeTopDownMRoute :: (PolyplateMRoute t BaseOpMRoute opT, Monad m) => +makeTopDownMRoute :: (AlloyARoute t BaseOpARoute opT, Monad m) => opT m outer -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t makeTopDownMRoute ops f (v, r) = do v' <- f (v, r) - transformMRoute baseOpMRoute ops (v', r) + transformMRoute baseOpARoute ops (v', r) {- TODO -makeCheckM :: PolyplateM t () opT m => opT -> (t -> m ()) -> t -> m t +makeCheckM :: AlloyA t () opT m => opT -> (t -> m ()) -> t -> m t makeCheckM ops f v = do v' <- descend v f v' @@ -89,8 +89,8 @@ makeCheckM ops f v -- 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 :: (PolyplateM t (OneOpM s) BaseOpM - ,PolyplateM s BaseOpM (OneOpM s)) => (s -> Bool) -> t -> [s] +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. @@ -99,8 +99,8 @@ listifyDepth qf = flip execState [] . applyBottomUpM qf' qf' x = if qf x then modify (x:) >> return x else return x -- | Like listifyDepth, but with routes -listifyDepthRoute :: (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute) - ,PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s)) +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 @@ -115,15 +115,15 @@ listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf' -- -- This can be used, for example, to perform checks on items in an error monad, -- or to accumulate information in a state monad. -checkDepthM :: (Monad m, PolyplateM t (OneOpM s) BaseOpM - , PolyplateM s BaseOpM (OneOpM s)) => (s -> m ()) -> t -> m () +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 () -- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the -- other on type \"s\"). -checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM r s) (BaseOpM) - , PolyplateM r (BaseOpM) (TwoOpM r s) - , PolyplateM s (BaseOpM) (TwoOpM r s) +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) @@ -137,54 +137,51 @@ checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x) -- traversal in order of a constructor's children (assuming you are using one of -- the generated instances, not your own), descending first and applying the function -- afterwards on the way back up. -applyBottomUpM :: (PolyplateM t (OneOpM s) BaseOpM, - PolyplateM s BaseOpM (OneOpM s), Monad m) => +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 = baseOpM `extOpM` makeBottomUpM ops f + ops = makeBottomUpM ops f :-* baseOpA applyBottomUpMRoute :: forall m s t. - (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute), - PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s), + (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 base (x, identityRoute) +applyBottomUpMRoute f x = transformMRoute ops baseOpARoute (x, identityRoute) where - base :: BaseOpMRoute m t - base = baseOpMRoute - - ops = base `extOpMRoute` makeBottomUpMRoute ops f + ops = makeBottomUpMRoute ops f :-@ baseOpARoute -- | As 'applyBottomUpM', but applies two functions. These should not be modifying -- the same type. -applyBottomUpM2 :: (PolyplateM t (TwoOpM sA sB) (BaseOpM), - PolyplateM sA (BaseOpM) (TwoOpM sA sB), - PolyplateM sB (BaseOpM) (TwoOpM sA sB), +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 :-* baseOpM + ops = makeBottomUpM ops fA :-* makeBottomUpM ops fB :-* baseOpA -- | As 'applyBottomUpM', but non-monadic. -applyBottomUp :: (Polyplate t (OneOp s) (), - Polyplate s () (OneOp s)) => +applyBottomUp :: (Alloy t (OneOp s) BaseOp, + Alloy s BaseOp (OneOp s)) => (s -> s) -> t -> t applyBottomUp f = makeRecurse ops where - ops = baseOp `extOp` makeBottomUp ops f + ops = makeBottomUp ops f :- baseOp -- | As 'applyBottomUpM2', but non-monadic. -applyBottomUp2 :: (Polyplate t (TwoOp sA sB) (), - Polyplate sA () (TwoOp sA sB), - Polyplate sB () (TwoOp sA sB)) => +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 = baseOp `extOp` makeBottomUp ops fA `extOp` makeBottomUp ops fB + ops = makeBottomUp ops fA :- makeBottomUp ops fB :- baseOp -- | Given a monadic function that applies to a particular type (\"s\"), automatically -- applies that function to every instance of \"s\" in a larger structure of type \"t\", @@ -192,30 +189,30 @@ applyBottomUp2 fA fB = makeRecurse ops -- traversal in order of a constructor's children (assuming you are using one of -- the generated instances, not your own), applying the function first and then -- descending. -applyTopDownM :: (PolyplateM t (s :-* BaseOpM) BaseOpM, - PolyplateM s BaseOpM (s :-* BaseOpM), +applyTopDownM :: (AlloyA t (s :-* BaseOpA) BaseOpA, + AlloyA s BaseOpA (s :-* BaseOpA), Monad m) => (s -> m s) -> t -> m t applyTopDownM f = makeRecurseM ops where - ops = makeTopDownM ops f :-* baseOpM + ops = makeTopDownM ops f :-* baseOpA -- | As applyTopDownM, but applies two functions. These should not be modifying -- the same type. -applyTopDownM2 :: (PolyplateM t (sA :-* sB :-* BaseOpM) BaseOpM, - PolyplateM sA BaseOpM (sA :-* sB :-* BaseOpM), - PolyplateM sB BaseOpM (sA :-* sB :-* BaseOpM), +applyTopDownM2 :: (AlloyA t (sA :-* sB :-* BaseOpA) BaseOpA, + AlloyA sA BaseOpA (sA :-* sB :-* BaseOpA), + AlloyA sB BaseOpA (sA :-* sB :-* BaseOpA), Monad m ) => (sA -> m sA) -> (sB -> m sB) -> t -> m t applyTopDownM2 fA fB = makeRecurseM ops where - ops = makeTopDownM ops fA :-* makeTopDownM ops fB :-* baseOpM + ops = makeTopDownM ops fA :-* makeTopDownM ops fB :-* baseOpA {- TODO -checkDepthM :: (Polyplate m (s -> m s, ()) () t, - Polyplate m () (s -> m s, ()) s) => +checkDepthM :: (Alloy m (s -> m s, ()) () t, + Alloy m () (s -> m s, ()) s) => (s -> m ()) -> t -> m t checkDepthM f = makeRecurse ops where diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index e0d493f..1114582 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -22,7 +22,7 @@ module BackendPasses (backendPasses, transformWaitFor, declareSizesArray) where import Control.Monad.Error import Control.Monad.State import Data.Generics (Data) -import Data.Generics.Polyplate +import Data.Generics.Alloy import Data.List import qualified Data.Map as Map import Data.Maybe @@ -99,7 +99,7 @@ removeUnneededDirections _ -> diePC m $ formatCode "Direction applied to non-channel type: %" t doVariable v = return v -type AllocMobileOps = ExtOpMS BaseOpM `ExtOpMP` A.Process +type AllocMobileOps = A.Process :-* ExtOpMS BaseOpM -- | Pulls up any initialisers for mobile allocations. I think, after all the -- other passes have run, the only place these initialisers should be left is in @@ -108,7 +108,7 @@ pullAllocMobile :: PassOnOps AllocMobileOps pullAllocMobile = cOnlyPass "Pull up mobile initialisers" [] [] recurse where ops :: AllocMobileOps PassM - ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess + ops = doProcess :-* opMS (ops, doStructured) recurse :: RecurseM PassM AllocMobileOps recurse = makeRecurseM ops @@ -334,7 +334,7 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" )) where ops :: DeclSizeOps SizesM - ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess + ops = doProcess :-* opMS (ops, doStructured) recurse :: RecurseM SizesM DeclSizeOps recurse = makeRecurseM ops @@ -424,8 +424,8 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" lit = A.ArrayListLiteral m $ A.Several m $ map (A.Only m) es t = A.Array [A.Dimension $ makeConstant m (length es)] A.Int - doStructured :: (Data a, PolyplateM (A.Structured a) DeclSizeOps BaseOpM - , PolyplateM (A.Structured a) BaseOpM DeclSizeOps) + doStructured :: (Data a, AlloyA (A.Structured a) DeclSizeOps BaseOpM + , AlloyA (A.Structured a) BaseOpM DeclSizeOps) => (A.Structured a) -> SizesM (A.Structured a) doStructured str@(A.Spec m sp@(A.Specification m' n spec) s) = do t <- typeOfSpec spec diff --git a/checks/ArrayUsageCheck.hs b/checks/ArrayUsageCheck.hs index cdd5891..6bc821b 100644 --- a/checks/ArrayUsageCheck.hs +++ b/checks/ArrayUsageCheck.hs @@ -46,7 +46,7 @@ import qualified Data.Traversable as T import qualified AST as A import CompState -import Data.Generics.Polyplate.Schemes +import Data.Generics.Alloy.Schemes import Errors import Metadata import Omega diff --git a/checks/Check.hs b/checks/Check.hs index 7ccc750..faa4959 100644 --- a/checks/Check.hs +++ b/checks/Check.hs @@ -37,7 +37,7 @@ import ArrayUsageCheck import qualified AST as A import CheckFramework import CompState -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy.Route import Errors import ExSet import FlowAlgorithms @@ -515,7 +515,7 @@ checkInitVar = forAnyFlowNode warnP m WarnUninitialisedVariable $ "Variable(s) read from are not written to before-hand: " ++ vars findAllProcess :: forall t m a. (Data t, Monad m, - PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute) + AlloyARoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute) => (A.Process -> Bool) -> FlowGraph' m a t -> A.Structured t -> [(A.Process, a)] findAllProcess f g t = Map.elems $ Map.intersectionWith (,) astMap nodeMap where @@ -531,7 +531,7 @@ findAllProcess f g t = Map.elems $ Map.intersectionWith (,) astMap nodeMap _ -> Nothing checkParAssignUsage :: forall m t. (CSMR m, Die m, MonadIO m, Data t, - PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute + AlloyARoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute ) => FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m () checkParAssignUsage g = mapM_ checkParAssign . findAllProcess isParAssign g where @@ -552,7 +552,7 @@ checkParAssignUsage g = mapM_ checkParAssign . findAllProcess isParAssign g $ processVarW v Nothing] | v <- vs] checkProcCallArgsUsage :: forall m t. (CSMR m, Die m, MonadIO m, Data t, - PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process) + AlloyARoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute ) => FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m () diff --git a/checks/CheckFramework.hs b/checks/CheckFramework.hs index f511a3d..7e058eb 100644 --- a/checks/CheckFramework.hs +++ b/checks/CheckFramework.hs @@ -36,7 +36,7 @@ import qualified Data.Set as Set import qualified AST as A import CompState -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy.Route import Errors import FlowAlgorithms import FlowGraph @@ -260,15 +260,15 @@ forAnyParItems = undefined -- | This function currently only supports one type forAnyASTTopDown :: forall a. - (PolyplateMRoute A.AST (a :-@ BaseOpMRoute) BaseOpMRoute - ,PolyplateMRoute a BaseOpMRoute (a :-@ BaseOpMRoute) + (AlloyARoute A.AST (a :-@ BaseOpMRoute) BaseOpMRoute + ,AlloyARoute a BaseOpMRoute (a :-@ BaseOpMRoute) ) => (a -> CheckOptASTM a ()) -> CheckOptM () forAnyASTTopDown origF = CheckOptM $ do tr <- get >>* ast doTree ops transformMRoute tr where - ops = baseOpMRoute `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM origF) + ops = (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM origF) :-@ baseOpMRoute forAnyASTStructTopDown :: (forall a. Data a => (A.Structured a -> CheckOptASTM (A.Structured a) ())) -> CheckOptM () @@ -277,27 +277,26 @@ forAnyASTStructTopDown origF = CheckOptM $ do doTree ops transformMRoute tr where ops - = baseOpMRoute - `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Variant -> CheckOptASTM (A.Structured A.Variant) ())) - `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Process -> CheckOptASTM (A.Structured A.Process) ())) - `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Option -> CheckOptASTM (A.Structured A.Option) ())) - `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.ExpressionList -> CheckOptASTM (A.Structured A.ExpressionList) ())) - `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Choice -> CheckOptASTM (A.Structured A.Choice) ())) - `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Alternative -> CheckOptASTM (A.Structured A.Alternative) ())) - `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured () -> CheckOptASTM (A.Structured ()) ())) + = (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Variant -> CheckOptASTM (A.Structured A.Variant) ())) + :-@ (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Process -> CheckOptASTM (A.Structured A.Process) ())) + :-@ (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Option -> CheckOptASTM (A.Structured A.Option) ())) + :-@ (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.ExpressionList -> CheckOptASTM (A.Structured A.ExpressionList) ())) + :-@ (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Choice -> CheckOptASTM (A.Structured A.Choice) ())) + :-@ (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Alternative -> CheckOptASTM (A.Structured A.Alternative) ())) + :-@ (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured () -> CheckOptASTM (A.Structured ()) ())) + :-@ baseOpMRoute -type ExtAcc a b = b :-@ a +type AccumOps b = b :-@ StructOps -type AccumOps b = - BaseOpMRoute - `ExtAcc` A.Structured A.Variant - `ExtAcc` A.Structured A.Process - `ExtAcc` A.Structured A.Option - `ExtAcc` A.Structured A.ExpressionList - `ExtAcc` A.Structured A.Choice - `ExtAcc` A.Structured A.Alternative - `ExtAcc` A.Structured () - `ExtAcc` b +type StructOps = + A.Structured A.Variant + :-@ A.Structured A.Process + :-@ A.Structured A.Option + :-@ A.Structured A.ExpressionList + :-@ A.Structured A.Choice + :-@ A.Structured A.Alternative + :-@ A.Structured () + :-@ BaseOpMRoute type SingleOps b = b :-@ BaseOpMRoute @@ -314,30 +313,30 @@ filterSub r = Map.filterWithKey (\k _ -> not $ r `isPrefixOf` k) -- I know the constraints here look horrendous, but it's really just three groups. forAnyASTStructBottomUpAccum :: forall b. (Data b, -- Allow us to descend into the AST with our full set of ops: - PolyplateMRoute A.AST (AccumOps b) BaseOpMRoute, + AlloyARoute A.AST (AccumOps b) BaseOpMRoute, -- Allow us to recurse into each Structured item (and b) with our full set of -- ops: - PolyplateMRoute (A.Structured A.Variant) BaseOpMRoute (AccumOps b), - PolyplateMRoute (A.Structured A.Process) BaseOpMRoute (AccumOps b), - PolyplateMRoute (A.Structured A.Option) BaseOpMRoute (AccumOps b), - PolyplateMRoute (A.Structured A.ExpressionList) BaseOpMRoute (AccumOps b), - PolyplateMRoute (A.Structured A.Choice) BaseOpMRoute (AccumOps b), - PolyplateMRoute (A.Structured A.Alternative) BaseOpMRoute (AccumOps b), - PolyplateMRoute (A.Structured ()) BaseOpMRoute (AccumOps b), - PolyplateMRoute b BaseOpMRoute (AccumOps b), + AlloyARoute (A.Structured A.Variant) BaseOpMRoute (AccumOps b), + AlloyARoute (A.Structured A.Process) BaseOpMRoute (AccumOps b), + AlloyARoute (A.Structured A.Option) BaseOpMRoute (AccumOps b), + AlloyARoute (A.Structured A.ExpressionList) BaseOpMRoute (AccumOps b), + AlloyARoute (A.Structured A.Choice) BaseOpMRoute (AccumOps b), + AlloyARoute (A.Structured A.Alternative) BaseOpMRoute (AccumOps b), + AlloyARoute (A.Structured ()) BaseOpMRoute (AccumOps b), + AlloyARoute b BaseOpMRoute (AccumOps b), -- Allow us to descend into each Structured item with just our ops for -- b, when our accumulated stuff becomes invalidated - PolyplateMRoute (A.Structured A.Variant) (SingleOps b) BaseOpMRoute, - PolyplateMRoute (A.Structured A.Process) (SingleOps b) BaseOpMRoute, - PolyplateMRoute (A.Structured A.Option) (SingleOps b) BaseOpMRoute, - PolyplateMRoute (A.Structured A.ExpressionList) (SingleOps b) BaseOpMRoute, - PolyplateMRoute (A.Structured A.Choice) (SingleOps b) BaseOpMRoute, - PolyplateMRoute (A.Structured A.Alternative) (SingleOps b) BaseOpMRoute, - PolyplateMRoute (A.Structured ()) (SingleOps b) BaseOpMRoute, + AlloyARoute (A.Structured A.Variant) (SingleOps b) BaseOpMRoute, + AlloyARoute (A.Structured A.Process) (SingleOps b) BaseOpMRoute, + AlloyARoute (A.Structured A.Option) (SingleOps b) BaseOpMRoute, + AlloyARoute (A.Structured A.ExpressionList) (SingleOps b) BaseOpMRoute, + AlloyARoute (A.Structured A.Choice) (SingleOps b) BaseOpMRoute, + AlloyARoute (A.Structured A.Alternative) (SingleOps b) BaseOpMRoute, + AlloyARoute (A.Structured ()) (SingleOps b) BaseOpMRoute, -- For b, we will recurse, not descend: - PolyplateMRoute b BaseOpMRoute (SingleOps b) + AlloyARoute b BaseOpMRoute (SingleOps b) ) => (forall a. Data a => (A.Structured a) -> CheckOptASTM' [b] (A.Structured a) ()) -> CheckOptM () @@ -349,7 +348,7 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do ops = applyAccum (undefined::b) allF keepApplying' :: - PolyplateMRoute t (b :-@ BaseOpMRoute) + AlloyARoute t (b :-@ BaseOpMRoute) BaseOpMRoute => ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) (Either t t)) -> ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) t) @@ -359,12 +358,12 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do Left y -> do -- remove all sub-items from state, -- and then scan the item anew: modify $ filterSub (routeId $ snd xr) - transformMRoute (applyAccum (undefined::b) BaseOpMRoute) BaseOpMRoute (y, snd xr) + transformMRoute (applyAccum (undefined::b) baseOpMRoute) baseOpMRoute (y, snd xr) keepApplying' f (y, snd xr) wrap :: forall a. (Data a, - PolyplateMRoute (A.Structured a) BaseOpMRoute (AccumOps b) - , PolyplateMRoute (A.Structured a) (b :-@ BaseOpMRoute) BaseOpMRoute + AlloyARoute (A.Structured a) BaseOpMRoute (AccumOps b) + , AlloyARoute (A.Structured a) (b :-@ BaseOpMRoute) BaseOpMRoute ) => ((A.Structured a, Route (A.Structured a) A.AST, [b]) -> RestartT CheckOptM (Either (A.Structured a) (A.Structured a))) -> (A.Structured a, Route (A.Structured a) A.AST) -> StateT (AccumMap b) (RestartT @@ -373,21 +372,21 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do (routeId y) z)) allF - = baseOpMRoute - `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Variant) -> + = (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Variant) -> CheckOptASTM' [b] (A.Structured A.Variant) ())) - `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Process) -> + :-@ (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Process) -> CheckOptASTM' [b] (A.Structured A.Process) ())) - `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Option) -> + :-@ (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Option) -> CheckOptASTM' [b] (A.Structured A.Option) ())) - `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.ExpressionList) -> + :-@ (wrap $ deCheckOptASTM' (origF :: (A.Structured A.ExpressionList) -> CheckOptASTM' [b] (A.Structured A.ExpressionList) ())) - `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Choice) -> + :-@ (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Choice) -> CheckOptASTM' [b] (A.Structured A.Choice) ())) - `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Alternative) -> + :-@ (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Alternative) -> CheckOptASTM' [b] (A.Structured A.Alternative) ())) - `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured ()) -> + :-@ (wrap $ deCheckOptASTM' (origF :: (A.Structured ()) -> CheckOptASTM' [b] (A.Structured ()) ())) + :-@ baseOpMRoute type TransFunc a = (a, Route a A.AST) -> RestartT CheckOptM (Either a a) type TransFuncAcc acc a = (a, Route a A.AST, acc) -> StateT acc (RestartT CheckOptM) (Either a a) @@ -401,7 +400,7 @@ doTree :: ops -> -- This line applies "apply" to the first thing of the right type in -- the given AST; from there, ops recurses for itself doTree ops trans tr - = do x <- deCheckOptM (getRestartT (trans ops BaseOpMRoute (tr, identityRoute) >> return ())) + = do x <- deCheckOptM (getRestartT (trans ops baseOpMRoute (tr, identityRoute) >> return ())) case x of Left _ -> do -- Restart tr' <- get >>* ast @@ -409,7 +408,7 @@ doTree ops trans tr Right _ -> return () applyAccum :: forall t ops. - PolyplateMRoute t BaseOpMRoute (t :-@ ops) + AlloyARoute t BaseOpMRoute (t :-@ ops) => t -> ops (StateT (AccumMap t) (RestartT CheckOptM)) A.AST -> (t :-@ ops) (StateT (AccumMap t) (RestartT CheckOptM)) A.AST applyAccum _ ops = ops' @@ -417,7 +416,7 @@ applyAccum _ ops = ops' ops' :: (t :-@ ops) (StateT (AccumMap t) (RestartT CheckOptM)) A.AST ops' = accum :-@ ops - accum xr = do x' <- transformMRoute BaseOpMRoute ops' xr + accum xr = do x' <- transformMRoute baseOpMRoute ops' xr modify $ Map.insert (routeId $ snd xr) x' return x' diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index dd7cb49..267891f 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -31,7 +31,7 @@ import qualified Data.Traversable as T import qualified AST as A import CompState -import Data.Generics.Polyplate.Schemes +import Data.Generics.Alloy.Schemes import Errors import FlowGraph import Metadata diff --git a/flow/FlowGraph.hs b/flow/FlowGraph.hs index 1678c66..80457cc 100644 --- a/flow/FlowGraph.hs +++ b/flow/FlowGraph.hs @@ -52,7 +52,7 @@ import Data.Maybe import qualified AST as A import CompState -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy.Route import Metadata import FlowUtils import Utils diff --git a/flow/FlowGraphTest.hs b/flow/FlowGraphTest.hs index a4ff195..8156b37 100644 --- a/flow/FlowGraphTest.hs +++ b/flow/FlowGraphTest.hs @@ -35,7 +35,7 @@ import Test.QuickCheck import qualified AST as A import CompState -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy.Route import FlowGraph import Metadata import PrettyShow diff --git a/flow/FlowUtils.hs b/flow/FlowUtils.hs index bb06678..ec77c5c 100644 --- a/flow/FlowUtils.hs +++ b/flow/FlowUtils.hs @@ -25,7 +25,7 @@ import Data.Generics (Data, Typeable) import Data.Graph.Inductive hiding (run) import qualified AST as A -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy.Route import Metadata import TreeUtils import Utils diff --git a/frontends/OccamCheckTypes.hs b/frontends/OccamCheckTypes.hs index 98a0935..a84ba54 100644 --- a/frontends/OccamCheckTypes.hs +++ b/frontends/OccamCheckTypes.hs @@ -49,14 +49,14 @@ ok = return () -- This is actually a series of smaller passes that check particular types -- inside the AST, but it doesn't really make sense to split it up. checkTypes :: - (PolyplateM t (OneOpM A.Variable) BaseOpM - ,PolyplateM t (OneOpM A.Expression) BaseOpM - ,PolyplateM t (OneOpM A.SpecType) BaseOpM - ,PolyplateM t (OneOpM A.Process) BaseOpM - ,PolyplateM t BaseOpM (OneOpM A.Variable) - ,PolyplateM t BaseOpM (OneOpM A.Expression) - ,PolyplateM t BaseOpM (OneOpM A.SpecType) - ,PolyplateM t BaseOpM (OneOpM A.Process) + (AlloyA t (OneOpM A.Variable) BaseOpM + ,AlloyA t (OneOpM A.Expression) BaseOpM + ,AlloyA t (OneOpM A.SpecType) BaseOpM + ,AlloyA t (OneOpM A.Process) BaseOpM + ,AlloyA t BaseOpM (OneOpM A.Variable) + ,AlloyA t BaseOpM (OneOpM A.Expression) + ,AlloyA t BaseOpM (OneOpM A.SpecType) + ,AlloyA t BaseOpM (OneOpM A.Process) ) => Pass t checkTypes = occamOnlyPass "Check types" [Prop.inferredTypesRecorded, Prop.ambiguitiesResolved] diff --git a/frontends/OccamInferTypes.hs b/frontends/OccamInferTypes.hs index a6e9eb3..6ac5db9 100644 --- a/frontends/OccamInferTypes.hs +++ b/frontends/OccamInferTypes.hs @@ -163,8 +163,6 @@ data InferTypeState = InferTypeState type InferTypeM = StateT InferTypeState PassM -type ExtOpMI ops t = t :-* ops - --{{{ type contexts -- | Enter a type context. @@ -193,15 +191,15 @@ getTypeContext -- I can't put this in the where clause of inferTypes, so it has to be out -- here. It should be the type of ops inside the inferTypes function below. type InferTypeOps - = ExtOpMS BaseOpM - `ExtOpMI` A.Expression - `ExtOpMI` A.Dimension - `ExtOpMI` A.Subscript - `ExtOpMI` A.Replicator - `ExtOpMI` A.Alternative - `ExtOpMI` A.Process - `ExtOpMI` A.Variable - `ExtOpMI` A.Variant + = A.Expression + :-* A.Dimension + :-* A.Subscript + :-* A.Replicator + :-* A.Alternative + :-* A.Process + :-* A.Variable + :-* A.Variant + :-* ExtOpMS BaseOpM type Infer a = a -> InferTypeM a @@ -213,16 +211,15 @@ inferTypes = occamOnlyPass "Infer types" (flip evalStateT (InferTypeState [] []) . recurse) where ops :: InferTypeOps InferTypeM - ops = baseOpM - `extOpMS` (ops, doStructured) - `extOpM` doExpression - `extOpM` doDimension - `extOpM` doSubscript - `extOpM` doReplicator - `extOpM` doAlternative - `extOpM` doProcess - `extOpM` doVariable - `extOpM` doVariant + ops = doExpression + :-* doDimension + :-* doSubscript + :-* doReplicator + :-* doAlternative + :-* doProcess + :-* doVariable + :-* doVariant + :-* opMS (ops, doStructured) recurse :: RecurseM InferTypeM InferTypeOps recurse = makeRecurseM ops @@ -365,14 +362,14 @@ inferTypes = occamOnlyPass "Infer types" = typeEqForOp t t' typeEqForOp t t' = t == t' - doActuals :: (PolyplateM a InferTypeOps BaseOpM, Data a) => Meta -> A.Name -> [A.Formal] -> + doActuals :: (AlloyA a InferTypeOps BaseOpM, Data a) => Meta -> A.Name -> [A.Formal] -> (Meta -> A.Direction -> Infer a, A.Type -> Infer a) -> Infer [a] doActuals m n fs applyDir_Deref as = do lift $ checkActualCount m n fs as sequence [doActual m applyDir_Deref t a | (A.Formal _ t _, a) <- zip fs as] -- First function directs, second function dereferences if needed - doActual :: (PolyplateM a InferTypeOps BaseOpM, Data a) => + doActual :: (AlloyA a InferTypeOps BaseOpM, Data a) => Meta -> (Meta -> A.Direction -> Infer a, A.Type -> Infer a) -> A.Type -> Infer a doActual m (applyDir, _) (A.ChanEnd dir _ _) a = recurse a >>= applyDir m dir doActual m (_, deref) t a = inTypeContext (Just t) $ recurse a >>= deref t @@ -458,8 +455,8 @@ inferTypes = occamOnlyPass "Infer types" mp' <- recurse mp return $ A.Variant m n iis' p' mp' - doStructured :: ( PolyplateM (A.Structured t) InferTypeOps BaseOpM - , PolyplateM (A.Structured t) BaseOpM InferTypeOps + doStructured :: ( AlloyA (A.Structured t) InferTypeOps BaseOpM + , AlloyA (A.Structured t) BaseOpM InferTypeOps , Data t) => Infer (A.Structured t) doStructured (A.Spec mspec s@(A.Specification m n st) body) @@ -470,8 +467,8 @@ inferTypes = occamOnlyPass "Infer types" doStructured s = descend s -- The second parameter is a modifier (wrapper) for the descent into the body - doSpecType :: ( PolyplateM (A.Structured t) InferTypeOps BaseOpM - , PolyplateM (A.Structured t) BaseOpM InferTypeOps + doSpecType :: ( AlloyA (A.Structured t) InferTypeOps BaseOpM + , AlloyA (A.Structured t) BaseOpM InferTypeOps , Data t) => A.Name -> A.SpecType -> ReaderT (A.Structured t) InferTypeM (A.SpecType, InferTypeM (A.Structured a) -> InferTypeM (A.Structured a)) doSpecType n st @@ -663,8 +660,8 @@ inferTypes = occamOnlyPass "Infer types" -- Also, to fit with the normal ops, we must do so in the PassM monad. -- Normally we would do this pass in a StateT monad, but to slip inside -- PassM, I've used an IORef instead. - findDir :: ( PolyplateM a InferTypeOps BaseOpM - , PolyplateM a BaseOpM InferTypeOps + findDir :: ( AlloyA a InferTypeOps BaseOpM + , AlloyA a BaseOpM InferTypeOps ) => A.Name -> a -> InferTypeM [A.Direction] findDir n x = do r <- liftIO $ newIORef [] @@ -675,16 +672,15 @@ inferTypes = occamOnlyPass "Infer types" makeOps r = ops where ops :: InferTypeOps InferTypeM - ops = baseOpM - `extOpMS` (ops, descend) - `extOpM` descend - `extOpM` descend - `extOpM` descend - `extOpM` descend - `extOpM` descend - `extOpM` descend - `extOpM` (doVariable r) - `extOpM` descend + ops = descend + :-* descend + :-* descend + :-* descend + :-* descend + :-* descend + :-* (doVariable r) + :-* descend + :-* opMS (ops, descend) descend :: DescendM InferTypeM InferTypeOps descend = makeDescendM ops diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index 6083ec3..5336b86 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -248,8 +248,7 @@ foldConstants = occamOnlyPass "Fold constants" = do modifyName n (\nd -> nd { A.ndSpecType = st }) return s -type CheckConstantsOps = BaseOpM `ExtOpMP` A.Type `ExtOpMP` A.Option - `ExtOpMP` A.SpecType +type CheckConstantsOps = A.Type :-* A.Option :-* A.SpecType :-* BaseOpM -- | Check that things that must be constant are. checkConstants :: PassOnOps CheckConstantsOps @@ -259,7 +258,7 @@ checkConstants = occamOnlyPass "Check mandatory constants" recurse where ops :: CheckConstantsOps PassM - ops = baseOpM `extOpM` doType `extOpM` doOption `extOpM` doSpecType + ops = doType :-* doOption :-* doSpecType :-* baseOpM descend :: DescendM PassM CheckConstantsOps descend = makeDescendM ops diff --git a/frontends/OccamPassesTest.hs b/frontends/OccamPassesTest.hs index 24c7112..7aa9b40 100644 --- a/frontends/OccamPassesTest.hs +++ b/frontends/OccamPassesTest.hs @@ -93,8 +93,8 @@ testFoldConstants = TestList , test 48 (add var (add const one)) (add var three) ] where - test :: (PolyplateM a (TwoOpM A.Expression A.Specification) BaseOpM - ,PolyplateM a BaseOpM (TwoOpM A.Expression A.Specification) + test :: (AlloyA a (TwoOpM A.Expression A.Specification) BaseOpM + ,AlloyA a BaseOpM (TwoOpM A.Expression A.Specification) ,Data a) => Int -> a -> a -> Test test n orig exp = TestCase $ testPass ("testFoldConstants" ++ show n) exp OccamPasses.foldConstants orig @@ -142,15 +142,15 @@ testCheckConstants = TestList , testFail 33 (A.Option m [lit10, lit10, lit10, var] skip) ] where - testOK :: (PolyplateM a OccamPasses.CheckConstantsOps BaseOpM - ,PolyplateM a BaseOpM OccamPasses.CheckConstantsOps + testOK :: (AlloyA a OccamPasses.CheckConstantsOps BaseOpM + ,AlloyA a BaseOpM OccamPasses.CheckConstantsOps ,Show a, Data a) => Int -> a -> Test testOK n orig = TestCase $ testPass ("testCheckConstants" ++ show n) orig OccamPasses.checkConstants orig (return ()) - testFail :: (PolyplateM a OccamPasses.CheckConstantsOps BaseOpM - ,PolyplateM a BaseOpM OccamPasses.CheckConstantsOps + testFail :: (AlloyA a OccamPasses.CheckConstantsOps BaseOpM + ,AlloyA a BaseOpM OccamPasses.CheckConstantsOps ,Show a, Data a) => Int -> a -> Test testFail n orig = TestCase $ testPassShouldFail ("testCheckConstants" ++ show n) diff --git a/frontends/OccamTypesTest.hs b/frontends/OccamTypesTest.hs index aa2c7b8..ca74a15 100644 --- a/frontends/OccamTypesTest.hs +++ b/frontends/OccamTypesTest.hs @@ -505,28 +505,28 @@ testOccamTypes = TestList --}}} ] where - testOK :: (PolyplateM a (OneOpM A.Variable) BaseOpM - ,PolyplateM a (OneOpM A.Expression) BaseOpM - ,PolyplateM a (OneOpM A.SpecType) BaseOpM - ,PolyplateM a (OneOpM A.Process) BaseOpM - ,PolyplateM a BaseOpM (OneOpM A.Variable) - ,PolyplateM a BaseOpM (OneOpM A.Expression) - ,PolyplateM a BaseOpM (OneOpM A.SpecType) - ,PolyplateM a BaseOpM (OneOpM A.Process) + testOK :: (AlloyA a (OneOpM A.Variable) BaseOpM + ,AlloyA a (OneOpM A.Expression) BaseOpM + ,AlloyA a (OneOpM A.SpecType) BaseOpM + ,AlloyA a (OneOpM A.Process) BaseOpM + ,AlloyA a BaseOpM (OneOpM A.Variable) + ,AlloyA a BaseOpM (OneOpM A.Expression) + ,AlloyA a BaseOpM (OneOpM A.SpecType) + ,AlloyA a BaseOpM (OneOpM A.Process) ,Show a, Data a) => Int -> a -> Test testOK n orig = TestCase $ testPass ("testOccamTypes " ++ show n) orig OccamTypes.checkTypes orig startState - testFail :: (PolyplateM a (OneOpM A.Variable) BaseOpM - ,PolyplateM a (OneOpM A.Expression) BaseOpM - ,PolyplateM a (OneOpM A.SpecType) BaseOpM - ,PolyplateM a (OneOpM A.Process) BaseOpM - ,PolyplateM a BaseOpM (OneOpM A.Variable) - ,PolyplateM a BaseOpM (OneOpM A.Expression) - ,PolyplateM a BaseOpM (OneOpM A.SpecType) - ,PolyplateM a BaseOpM (OneOpM A.Process) + testFail :: (AlloyA a (OneOpM A.Variable) BaseOpM + ,AlloyA a (OneOpM A.Expression) BaseOpM + ,AlloyA a (OneOpM A.SpecType) BaseOpM + ,AlloyA a (OneOpM A.Process) BaseOpM + ,AlloyA a BaseOpM (OneOpM A.Variable) + ,AlloyA a BaseOpM (OneOpM A.Expression) + ,AlloyA a BaseOpM (OneOpM A.SpecType) + ,AlloyA a BaseOpM (OneOpM A.Process) ,Show a, Data a) => Int -> a -> Test testFail n orig = TestCase $ testPassShouldFail ("testOccamTypes " ++ show n) diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 8df87b3..424e457 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -61,11 +61,11 @@ type RainTypeM = StateT RainTypeState PassM type RainTypePassType = forall t. t -> StateT RainTypeState PassM t -type RainTypeCheckOn a = forall t. PolyplateM t (OneOpM a) BaseOpM +type RainTypeCheckOn a = forall t. AlloyA t (OneOpM a) BaseOpM => t -> RainTypeM () type RainTypeCheckOn2 a b = forall t. - (PolyplateM t (TwoOpM a b) BaseOpM + (AlloyA t (TwoOpM a b) BaseOpM ) => t -> RainTypeM () @@ -122,14 +122,14 @@ markUnify x y performTypeUnification :: -- | A shorthand for prerequisites when you need to spell them out: - (PolyplateM t (OneOpM A.Specification) BaseOpM - ,PolyplateM t (OneOpM A.Process) BaseOpM - ,PolyplateM t (OneOpM A.Expression) BaseOpM - ,PolyplateM t (TwoOpM A.Process A.Expression) BaseOpM - ,PolyplateM t (TwoOpM A.Process A.Choice) BaseOpM - ,PolyplateM t (TwoOpM A.Process A.Alternative) BaseOpM - ,PolyplateM t BaseOpM (OneOpM A.Type) - ,PolyplateM t (OneOpM A.Type) BaseOpM + (AlloyA t (OneOpM A.Specification) BaseOpM + ,AlloyA t (OneOpM A.Process) BaseOpM + ,AlloyA t (OneOpM A.Expression) BaseOpM + ,AlloyA t (TwoOpM A.Process A.Expression) BaseOpM + ,AlloyA t (TwoOpM A.Process A.Choice) BaseOpM + ,AlloyA t (TwoOpM A.Process A.Alternative) BaseOpM + ,AlloyA t BaseOpM (OneOpM A.Type) + ,AlloyA t (OneOpM A.Type) BaseOpM ) => Pass t performTypeUnification = rainOnlyPass "Rain Type Checking" ([Prop.noInt] ++ Prop.agg_namesDone) diff --git a/pass/Pass.hs b/pass/Pass.hs index 15bfb7e..ca0c979 100644 --- a/pass/Pass.hs +++ b/pass/Pass.hs @@ -24,7 +24,7 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Data.Generics (Constr, Data) -import Data.Generics.Polyplate +import Data.Generics.Alloy import Data.List import Data.Ord import qualified Data.Set as Set @@ -97,21 +97,19 @@ instance Warn (ReaderT r PassM) where -- against AST fragments of other types as well. type PassType t = t -> PassM t -type PassOnOpsM ops - = (PolyplateM t ops BaseOpM, PolyplateM t BaseOpM ops) => Pass t - -type PassOnOps ops = PassOnOpsM ops +type PassOnOps ops + = (AlloyA t ops BaseOpA, AlloyA t BaseOpA ops) => Pass t type PassASTOnOps ops - = (PolyplateM A.AST ops BaseOpM, PolyplateM A.AST BaseOpM ops) => Pass A.AST + = (AlloyA A.AST ops BaseOpA, AlloyA A.AST BaseOpA ops) => Pass A.AST type PassTypeOnOps ops - = (PolyplateM t ops BaseOpM, PolyplateM t BaseOpM ops) => PassType t + = (AlloyA t ops BaseOpA, AlloyA t BaseOpA ops) => PassType t -type PassOn t = PassOnOps (OneOpM t) -type PassOn2 s t = PassOnOps (TwoOpM s t) -type PassOnM2 s t = PassOnOpsM (TwoOpM s t) -type PassTypeOn t = PassTypeOnOps (OneOpM t) +type PassOn t = PassOnOps (OneOpA t) +type PassOn2 s t = PassOnOps (TwoOpA s t) +type PassTypeOn t = PassTypeOnOps (OneOpA t) +type PassTypeOn2 s t = PassTypeOnOps (TwoOpA s t) -- | A description of an AST-mangling pass. data Pass t = Pass { diff --git a/pass/Traversal.hs b/pass/Traversal.hs index d2f15a3..72b0d38 100644 --- a/pass/Traversal.hs +++ b/pass/Traversal.hs @@ -21,22 +21,35 @@ with this program. If not, see . module Traversal ( TransformM, Transform, TransformStructured, TransformStructured', TransformStructuredM' , CheckM, Check - , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct + , ExtOpMS, ExtOpMSP, extOpMS, opMS, PassOnStruct, PassASTOnStruct , applyBottomUpMS, ASTStructured - , module Data.Generics.Polyplate - , module Data.Generics.Polyplate.Schemes + , RecurseM, DescendM, BaseOpM, baseOpM, OneOpM, TwoOpM, BaseOpMRoute, baseOpMRoute, OneOpMRoute + , module Data.Generics.Alloy + , module Data.Generics.Alloy.Schemes ) where import Control.Monad.State import Data.Generics (Data) -import Data.Generics.Polyplate -import Data.Generics.Polyplate.Schemes +import Data.Generics.Alloy +import Data.Generics.Alloy.Schemes import qualified AST as A import NavAST() import Pass +type RecurseM a b = RecurseA a b +type DescendM a b = DescendA a b +type BaseOpM = BaseOpA +type BaseOpMRoute = BaseOpARoute +type OneOpM s = OneOpA s +type OneOpMRoute s = OneOpARoute s +type TwoOpM s t = TwoOpA s t +baseOpM :: BaseOpM m +baseOpM = baseOpA +baseOpMRoute :: BaseOpMRoute m outer +baseOpMRoute = baseOpARoute + -- | A transformation for a single 'Data' type. type TransformM m t = t -> m t @@ -51,8 +64,6 @@ type CheckM m t = t -> m () -- | As 'CheckM', but specialised for 'PassM'. type Check t = CheckM PassM t -type ExtOpMP opT t = t :-* opT - type ExtOpMS opT = (A.Structured ()) :-* (A.Structured A.Alternative) :-* @@ -65,59 +76,59 @@ type ExtOpMS opT = type ExtOpMSP opT = ExtOpMS opT PassM -type PassOnStruct = PassOnOps (ExtOpMS BaseOpM) -type PassASTOnStruct = PassASTOnOps (ExtOpMS BaseOpM) +type PassOnStruct = PassOnOps (ExtOpMS BaseOpA) +type PassASTOnStruct = PassASTOnOps (ExtOpMS BaseOpA) -class (PolyplateM (A.Structured a) BaseOpM opsM - ,PolyplateM (A.Structured a) opsM BaseOpM +class (AlloyA (A.Structured a) BaseOpA opsM + ,AlloyA (A.Structured a) opsM BaseOpA ,Data a ,Monad m ) => ASTStructured a opsM m opsQ r -instance (PolyplateM (A.Structured ()) BaseOpM opsM - ,PolyplateM (A.Structured ()) opsM BaseOpM +instance (AlloyA (A.Structured ()) BaseOpA opsM + ,AlloyA (A.Structured ()) opsM BaseOpA ,Monad m) => ASTStructured () opsM m opsQ r -instance (PolyplateM (A.Structured A.Alternative) BaseOpM opsM - ,PolyplateM (A.Structured A.Alternative) opsM BaseOpM +instance (AlloyA (A.Structured A.Alternative) BaseOpA opsM + ,AlloyA (A.Structured A.Alternative) opsM BaseOpA ,Monad m) => ASTStructured A.Alternative opsM m opsQ r -instance (PolyplateM (A.Structured A.Choice) BaseOpM opsM - ,PolyplateM (A.Structured A.Choice) opsM BaseOpM +instance (AlloyA (A.Structured A.Choice) BaseOpA opsM + ,AlloyA (A.Structured A.Choice) opsM BaseOpA ,Monad m) => ASTStructured A.Choice opsM m opsQ r -instance (PolyplateM (A.Structured A.ExpressionList) BaseOpM opsM - ,PolyplateM (A.Structured A.ExpressionList) opsM BaseOpM +instance (AlloyA (A.Structured A.ExpressionList) BaseOpA opsM + ,AlloyA (A.Structured A.ExpressionList) opsM BaseOpA ,Monad m) => ASTStructured A.ExpressionList opsM m opsQ r -instance (PolyplateM (A.Structured A.Option) BaseOpM opsM - ,PolyplateM (A.Structured A.Option) opsM BaseOpM +instance (AlloyA (A.Structured A.Option) BaseOpA opsM + ,AlloyA (A.Structured A.Option) opsM BaseOpA ,Monad m) => ASTStructured A.Option opsM m opsQ r -instance (PolyplateM (A.Structured A.Process) BaseOpM opsM - ,PolyplateM (A.Structured A.Process) opsM BaseOpM +instance (AlloyA (A.Structured A.Process) BaseOpA opsM + ,AlloyA (A.Structured A.Process) opsM BaseOpA ,Monad m) => ASTStructured A.Process opsM m opsQ r -instance (PolyplateM (A.Structured A.Variant) BaseOpM opsM - ,PolyplateM (A.Structured A.Variant) opsM BaseOpM +instance (AlloyA (A.Structured A.Variant) BaseOpA opsM + ,AlloyA (A.Structured A.Variant) opsM BaseOpA ,Monad m) => ASTStructured A.Variant opsM m opsQ r extOpMS :: forall m opT op0T. - (PolyplateM (A.Structured ()) BaseOpM op0T, - PolyplateM (A.Structured A.Alternative) BaseOpM op0T, - PolyplateM (A.Structured A.Choice) BaseOpM op0T, - PolyplateM (A.Structured A.ExpressionList) BaseOpM op0T, - PolyplateM (A.Structured A.Option) BaseOpM op0T, - PolyplateM (A.Structured A.Process) BaseOpM op0T, - PolyplateM (A.Structured A.Variant) BaseOpM op0T, - PolyplateM (A.Structured ()) op0T BaseOpM, - PolyplateM (A.Structured A.Alternative) op0T BaseOpM, - PolyplateM (A.Structured A.Choice) op0T BaseOpM, - PolyplateM (A.Structured A.ExpressionList) op0T BaseOpM, - PolyplateM (A.Structured A.Option) op0T BaseOpM, - PolyplateM (A.Structured A.Process) op0T BaseOpM, - PolyplateM (A.Structured A.Variant) op0T BaseOpM, + (AlloyA (A.Structured ()) BaseOpA op0T, + AlloyA (A.Structured A.Alternative) BaseOpA op0T, + AlloyA (A.Structured A.Choice) BaseOpA op0T, + AlloyA (A.Structured A.ExpressionList) BaseOpA op0T, + AlloyA (A.Structured A.Option) BaseOpA op0T, + AlloyA (A.Structured A.Process) BaseOpA op0T, + AlloyA (A.Structured A.Variant) BaseOpA op0T, + AlloyA (A.Structured ()) op0T BaseOpA, + AlloyA (A.Structured A.Alternative) op0T BaseOpA, + AlloyA (A.Structured A.Choice) op0T BaseOpA, + AlloyA (A.Structured A.ExpressionList) op0T BaseOpA, + AlloyA (A.Structured A.Option) op0T BaseOpA, + AlloyA (A.Structured A.Process) op0T BaseOpA, + AlloyA (A.Structured A.Variant) op0T BaseOpA, Monad m) => opT m -> -- Pairing the next two arguments allows us to apply this function infix: @@ -125,30 +136,45 @@ extOpMS :: forall m opT op0T. forall t. ASTStructured t op0T m () () => A.Structured t -> m (A.Structured t)) -> ExtOpMS opT m extOpMS ops (_, f) - = ops - `extOpM` (f :: A.Structured A.Variant -> m (A.Structured A.Variant)) - `extOpM` (f :: A.Structured A.Process -> m (A.Structured A.Process)) - `extOpM` (f :: A.Structured A.Option -> m (A.Structured A.Option)) - `extOpM` (f :: A.Structured A.ExpressionList -> m (A.Structured A.ExpressionList)) - `extOpM` (f :: A.Structured A.Choice -> m (A.Structured A.Choice)) - `extOpM` (f :: A.Structured A.Alternative -> m (A.Structured A.Alternative)) - `extOpM` (f :: A.Structured () -> m (A.Structured ())) + = f :-* f :-* f :-* f :-* f :-* f :-* f :-* ops -applyBottomUpMS :: (PolyplateM t (ExtOpMS BaseOpM) BaseOpM) => - (forall a. (Data a, PolyplateM (A.Structured a) BaseOpM (ExtOpMS BaseOpM)) => +opMS :: forall m op0T. + (AlloyA (A.Structured ()) BaseOpA op0T, + AlloyA (A.Structured A.Alternative) BaseOpA op0T, + AlloyA (A.Structured A.Choice) BaseOpA op0T, + AlloyA (A.Structured A.ExpressionList) BaseOpA op0T, + AlloyA (A.Structured A.Option) BaseOpA op0T, + AlloyA (A.Structured A.Process) BaseOpA op0T, + AlloyA (A.Structured A.Variant) BaseOpA op0T, + AlloyA (A.Structured ()) op0T BaseOpA, + AlloyA (A.Structured A.Alternative) op0T BaseOpA, + AlloyA (A.Structured A.Choice) op0T BaseOpA, + AlloyA (A.Structured A.ExpressionList) op0T BaseOpA, + AlloyA (A.Structured A.Option) op0T BaseOpA, + AlloyA (A.Structured A.Process) op0T BaseOpA, + AlloyA (A.Structured A.Variant) op0T BaseOpA, + Monad m) => + -- Pairing the next two arguments allows us to apply this function infix: + (op0T m, -- just a type witness + forall t. ASTStructured t op0T m () () => A.Structured t -> m (A.Structured t)) -> + ExtOpMS BaseOpA m +opMS x = extOpMS baseOpA x + +applyBottomUpMS :: (AlloyA t (ExtOpMS BaseOpA) BaseOpA) => + (forall a. (Data a, AlloyA (A.Structured a) BaseOpA (ExtOpMS BaseOpA)) => (A.Structured a -> PassM (A.Structured a))) -> t -> PassM t applyBottomUpMS f = makeRecurseM ops where - ops = baseOpM `extOpMS` (ops, makeBottomUpM ops f) + ops = baseOpA `extOpMS` (ops, makeBottomUpM ops f) type TransformStructured ops - = (PolyplateM (A.Structured t) BaseOpM ops, Data t) => Transform (A.Structured t) + = (AlloyA (A.Structured t) BaseOpA ops, Data t) => Transform (A.Structured t) type TransformStructured' ops - = (PolyplateM (A.Structured t) BaseOpM ops - ,PolyplateM (A.Structured t) ops BaseOpM, Data t) => Transform (A.Structured t) + = (AlloyA (A.Structured t) BaseOpA ops + ,AlloyA (A.Structured t) ops BaseOpA, Data t) => Transform (A.Structured t) type TransformStructuredM' m ops - = (PolyplateM (A.Structured t) BaseOpM ops - ,PolyplateM (A.Structured t) ops BaseOpM, Data t) => A.Structured t -> m (A.Structured t) + = (AlloyA (A.Structured t) BaseOpA ops + ,AlloyA (A.Structured t) ops BaseOpA, Data t) => A.Structured t -> m (A.Structured t) diff --git a/pregen/GenNavAST.hs b/pregen/GenNavAST.hs index 73461cc..51ce77d 100644 --- a/pregen/GenNavAST.hs +++ b/pregen/GenNavAST.hs @@ -23,7 +23,7 @@ import Data.List import System.Environment import qualified Data.Set as Set -import Data.Generics.Polyplate.GenInstances +import Data.Generics.Alloy.GenInstances import qualified AST import qualified CompState @@ -65,8 +65,8 @@ main = do ,"" ,"import Control.Applicative" ,"import Control.Monad" - ,"import Data.Generics.Polyplate" - ,if isSpine then "" else "import Data.Generics.Polyplate.Route" + ,"import Data.Generics.Alloy" + ,if isSpine then "" else "import Data.Generics.Alloy.Route" ,"" ,"import Data.Map (Map)" ,"import qualified Data.Map as Map" diff --git a/transformations/ImplicitMobility.hs b/transformations/ImplicitMobility.hs index f349d73..0fb2569 100644 --- a/transformations/ImplicitMobility.hs +++ b/transformations/ImplicitMobility.hs @@ -30,7 +30,7 @@ import qualified Data.Traversable as T import qualified AST as A import CompState -import Data.Generics.Polyplate.Route +import Data.Generics.Alloy.Route import Errors import FlowAlgorithms import FlowGraph @@ -204,7 +204,7 @@ mobiliseArrays :: PassASTOnStruct mobiliseArrays = pass "Make all arrays mobile" [] [] recurse where ops :: ExtOpMSP BaseOpM - ops = baseOpM `extOpMS` (ops, doStructured) + ops = opMS (ops, doStructured) recurse :: RecurseM PassM (ExtOpMS BaseOpM) recurse = makeRecurseM ops diff --git a/transformations/SimplifyAbbrevs.hs b/transformations/SimplifyAbbrevs.hs index 8e7ffae..c8fc60c 100644 --- a/transformations/SimplifyAbbrevs.hs +++ b/transformations/SimplifyAbbrevs.hs @@ -166,7 +166,7 @@ removeInitial specVar (A.Specification m n _) = A.Variable m n -- | Rewrite 'ResultAbbrev' into just 'Abbrev'. -removeResult :: Polyplate t (OneOp A.AbbrevMode) () => Pass t +removeResult :: Alloy t (OneOp A.AbbrevMode) BaseOp => Pass t removeResult = pass "Remove RESULT abbreviations" [] @@ -193,26 +193,25 @@ updateAbbrevsInState type AbbrevCheckM = StateT [Map.Map Var Bool] PassM type AbbrevCheckOps - = ExtOpMS BaseOpM - `ExtOpMP` A.Variable - `ExtOpMP` A.Process - `ExtOpMP` A.InputItem + = A.Variable + :-* A.Process + :-* A.InputItem + :-* ExtOpMS BaseOpM -abbrevCheckPass :: (PolyplateM t AbbrevCheckOps BaseOpM, PolyplateM t BaseOpM AbbrevCheckOps) => Pass t +abbrevCheckPass :: (AlloyA t AbbrevCheckOps BaseOpM, AlloyA t BaseOpM AbbrevCheckOps) => Pass t abbrevCheckPass = pass "Abbreviation checking" [] [] ({-passOnlyOnAST "abbrevCheck" $ -} flip evalStateT [Map.empty] . recurse) where ops :: AbbrevCheckOps AbbrevCheckM - ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doVariable - `extOpM` doProcess `extOpM` doInputItem + ops = doVariable :-* doProcess :-* doInputItem :-* opMS (ops, doStructured) descend :: DescendM AbbrevCheckM AbbrevCheckOps descend = makeDescendM ops recurse :: RecurseM AbbrevCheckM AbbrevCheckOps recurse = makeRecurseM ops - pushRecurse :: (PolyplateM a AbbrevCheckOps BaseOpM) => a -> AbbrevCheckM a + pushRecurse :: (AlloyA a AbbrevCheckOps BaseOpM) => a -> AbbrevCheckM a pushRecurse x = modify (Map.empty:) >> recurse x pop :: StateT [Map.Map Var Bool] PassM () pop = modify $ \st -> case st of @@ -232,8 +231,8 @@ abbrevCheckPass -- on an abbreviation if either the RHS *or* the LHS is exempt by a PERMITALIASEs -- pragma - doStructured :: (PolyplateM (A.Structured t) BaseOpM AbbrevCheckOps - ,PolyplateM (A.Structured t) AbbrevCheckOps BaseOpM, Data t) => + doStructured :: (AlloyA (A.Structured t) BaseOpM AbbrevCheckOps + ,AlloyA (A.Structured t) AbbrevCheckOps BaseOpM, Data t) => A.Structured t -> AbbrevCheckM (A.Structured t) doStructured s@(A.Spec _ (A.Specification _ n (A.Is _ A.Abbrev _ (A.ActualVariable v))) scope) = do nonce <- nameIsNonce n diff --git a/transformations/SimplifyAbbrevsTest.hs b/transformations/SimplifyAbbrevsTest.hs index 3ea858f..3efdf7f 100644 --- a/transformations/SimplifyAbbrevsTest.hs +++ b/transformations/SimplifyAbbrevsTest.hs @@ -94,8 +94,8 @@ testRemoveInitial = TestLabel "testRemoveInitial" $ TestList inner) ] where - ok :: (PolyplateM a (ExtOpMS BaseOpM) BaseOpM - ,PolyplateM a BaseOpM (ExtOpMS BaseOpM) + ok :: (AlloyA a (ExtOpMS BaseOpM) BaseOpM + ,AlloyA a BaseOpM (ExtOpMS BaseOpM) ,Data a, Data b) => Int -> a -> b -> Test ok n inp exp = TestCase $ testPass ("testRemoveInitial" ++ show n) exp removeInitial inp setupState @@ -152,7 +152,7 @@ testRemoveResult = TestLabel "testRemoveResult" $ TestList (A.Formal A.Abbrev A.Int foo) ] where - ok :: (Polyplate a (OneOp A.AbbrevMode) BaseOp + ok :: (Alloy a (OneOp A.AbbrevMode) BaseOp ,Data a, Data b) => Int -> a -> b -> Test ok n inp exp = TestCase $ testPass ("testRemoveResult" ++ show n) exp removeResult inp setupState diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index 9f6825f..1c91bed 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -323,14 +323,15 @@ transformConstr = pass "Transform array constructors into initialisation code" doStructured s = return s -type PullUpOps = ExtOpMS BaseOpM - `ExtOpMP` A.Process - `ExtOpMP` A.Structured A.Expression - `ExtOpMP` A.Specification - `ExtOpMP` A.LiteralRepr - `ExtOpMP` A.Expression - `ExtOpMP` A.Variable - `ExtOpMP` A.ExpressionList +type PullUpOps = + A.Process + :-* A.Structured A.Expression + :-* A.Specification + :-* A.LiteralRepr + :-* A.Expression + :-* A.Variable + :-* A.ExpressionList + :-* ExtOpMS BaseOpM -- | Find things that need to be moved up to their enclosing Structured, and do -- so. @@ -341,15 +342,14 @@ pullUp pullUpArraysInsideRecords = pass "Pull up definitions" recurse where ops :: PullUpOps PassM - ops = baseOpM - `extOpMS` (ops, doStructured) - `extOpM` doProcess - `extOpM` doRepArray - `extOpM` doSpecification - `extOpM` doLiteralRepr - `extOpM` doExpression - `extOpM` doVariable - `extOpM` doExpressionList + ops = doProcess + :-* doRepArray + :-* doSpecification + :-* doLiteralRepr + :-* doExpression + :-* doVariable + :-* doExpressionList + :-* opMS (ops, doStructured) recurse :: RecurseM PassM PullUpOps recurse = makeRecurseM ops descend :: DescendM PassM PullUpOps diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 7b61b7e..ccc6a46 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -48,12 +48,12 @@ type ForkM = StateT [A.Name] PassM type ForkOps = A.Process :-* (ExtOpMS BaseOpM) -- | Add an extra barrier parameter to every PROC for FORKING -addForkNames :: PassOnOpsM ForkOps +addForkNames :: PassOnOps ForkOps addForkNames = occamOnlyPass "Add FORK labels" [] [] (flip evalStateT [] . recurse) where ops :: ForkOps ForkM - ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess + ops = doProcess :-* opMS (ops, doStructured) recurse :: RecurseM ForkM ForkOps recurse = makeRecurseM ops @@ -159,8 +159,7 @@ flattenAssign = pass "Flatten assignment" [Prop.assignFlattened] (makeRecurseM ops) where - ops = baseOpM `extOpMS` (ops, makeBottomUpM ops doStructured) - `extOpM` makeBottomUpM ops doProcess + ops = makeBottomUpM ops doProcess :-* opMS (ops, makeBottomUpM ops doStructured) doProcess :: A.Process -> PassM A.Process doProcess (A.Assign m [v] (A.ExpressionList m' [e])) diff --git a/transformations/SimplifyTypesTest.hs b/transformations/SimplifyTypesTest.hs index 3bd7802..7bf4f0a 100644 --- a/transformations/SimplifyTypesTest.hs +++ b/transformations/SimplifyTypesTest.hs @@ -51,8 +51,8 @@ testResolveNamedTypes = TestLabel "testResolveNamedTypes" $ TestList (array10 A.Int) ] where - ok :: (PolyplateM a (OneOpM A.Type) BaseOpM - ,PolyplateM a BaseOpM (OneOpM A.Type) + ok :: (AlloyA a (OneOpM A.Type) BaseOpM + ,AlloyA a BaseOpM (OneOpM A.Type) ,Data a, Data b) => Int -> a -> b -> Test ok n inp exp = TestCase $ testPass ("testResolveNamedTypes" ++ show n) exp resolveNamedTypes inp setupState diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index 469f233..728dbda 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -48,22 +48,22 @@ type NameMap = Map.Map String A.Name type FreeNameM = State (Map.Map String A.Name) -type FreeNameOps = A.SpecType :-* (ExtOpMS (A.Name :-* BaseOpM)) +type FreeNameOps = A.SpecType :-* A.Name :-* ExtOpMS BaseOpM -- | Get the set of free names within a block of code. -freeNamesIn :: PolyplateM t FreeNameOps BaseOpM => t -> NameMap +freeNamesIn :: AlloyA t FreeNameOps BaseOpM => t -> NameMap freeNamesIn = flip execState Map.empty . recurse where flattenTree :: Tree (Maybe NameMap) -> NameMap flattenTree = foldl Map.union Map.empty . catMaybes . flatten ops :: FreeNameOps FreeNameM - ops = baseOpM `extOpM` doName `extOpMS` (ops, doStructured) `extOpM` doSpecType + ops = doSpecType :-* doName :-* opMS (ops, doStructured) - recurse :: PolyplateM t FreeNameOps BaseOpM => t -> FreeNameM t - recurse = transformM ops baseOpM - descend :: PolyplateM t BaseOpM FreeNameOps => t -> FreeNameM t - descend = transformM baseOpM ops + recurse :: RecurseA FreeNameM FreeNameOps + recurse = makeRecurseM ops + descend :: DescendA FreeNameM FreeNameOps + descend = makeDescendM ops ignore :: t -> NameMap ignore s = Map.empty @@ -71,15 +71,15 @@ freeNamesIn = flip execState Map.empty . recurse doName :: A.Name -> FreeNameM A.Name doName n = modify (Map.insert (A.nameName n) n) >> return n - doStructured :: (Data a, PolyplateM (A.Structured a) BaseOpM FreeNameOps - , PolyplateM (A.Structured a) FreeNameOps BaseOpM + doStructured :: (Data a, AlloyA (A.Structured a) BaseOpM FreeNameOps + , AlloyA (A.Structured a) FreeNameOps BaseOpM ) => A.Structured a -> FreeNameM (A.Structured a) doStructured x@(A.Spec _ spec s) = doSpec spec s >> return x doStructured s = descend s - doSpec :: (PolyplateM t BaseOpM FreeNameOps - ,PolyplateM t FreeNameOps BaseOpM) => A.Specification -> t -> FreeNameM () + doSpec :: (AlloyA t BaseOpM FreeNameOps + ,AlloyA t FreeNameOps BaseOpM) => A.Specification -> t -> FreeNameM () doSpec (A.Specification _ n st) child = modify (Map.union $ Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child) where @@ -98,15 +98,15 @@ freeNamesIn = flip execState Map.empty . recurse -- have expressions as dimensions, and those expressions can contain free names -- which are being replaced. This is fine, but when that happens we need to update -- CompState so that the type has the replaced name, not the old name. -replaceNames :: PolyplateM t (TwoOpM A.Name A.Specification) BaseOpM => [(A.Name, A.Name)] -> t -> PassM t +replaceNames :: AlloyA t (TwoOpA A.Name A.Specification) BaseOpM => [(A.Name, A.Name)] -> t -> PassM t replaceNames map = recurse where smap = Map.fromList [(A.nameName f, t) | (f, t) <- map] - ops :: TwoOpM A.Name A.Specification PassM - ops = doName :-* doSpecification :-* baseOpM + ops :: TwoOpA A.Name A.Specification PassM + ops = doName :-* doSpecification :-* baseOpA - recurse :: RecurseM PassM (TwoOpM A.Name A.Specification) + recurse :: RecurseA PassM (TwoOpA A.Name A.Specification) recurse = makeRecurseM ops doName :: Transform A.Name @@ -124,7 +124,7 @@ replaceNames map = recurse return $ A.Specification m n' sp' -- | Turn free names in PROCs into arguments. -removeFreeNames :: PassOnM2 A.Specification A.Process +removeFreeNames :: PassOn2 A.Specification A.Process removeFreeNames = pass "Convert free names to arguments" [Prop.mainTagged, Prop.parsWrapped, Prop.functionCallsRemoved] [Prop.freeNamesToArgs] @@ -224,12 +224,12 @@ removeNesting = pass "Pull nested definitions to top level" return s') where ops :: ExtOpMSP BaseOpM - ops = baseOpM `extOpMS` (ops, doStructured) + ops = baseOpA `extOpMS` (ops, doStructured) - recurse :: RecurseM PassM (ExtOpMS BaseOpM) + recurse :: RecurseA PassM (ExtOpMS BaseOpM) recurse = makeRecurseM ops - descend :: DescendM PassM (ExtOpMS BaseOpM) + descend :: DescendA PassM (ExtOpMS BaseOpM) descend = makeDescendM ops doStructured :: TransformStructured (ExtOpMS BaseOpM)