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

Finished the name change from Polyplate to Alloy

Browse Source 
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.
This commit is contained in:
Neil Brown 2009-05-11 15:22:58 +00:00
parent bee000b9c7
commit 853a52cc00
28 changed files with 464 additions and 495 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

210
alloy/Data/Generics/Alloy.hs
View File

@ -16,21 +16,21 @@ You should have received a copy of the GNU General Public License along
with this program. If not, see <http://www.gnu.org/licenses/>.
-}
-- | This is the primary module for the polyplate library, that declares the type-class
-- | 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: <http://www.cs.vu.nl/boilerplate/testsuite/paradise/CompanyDatatypes.hs>
@ -39,14 +39,14 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- 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 <http://www.gnu.org/licenses/>.
-- from <http://www.cs.vu.nl/boilerplate/testsuite/paradise/Main.hs>):
--
-- > 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 <http://www.gnu.org/licenses/>.
-- > 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)
-}
-- }}}

72
alloy/Data/Generics/Alloy/GenInstances.hs
View File

@ -35,7 +35,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
--
-- > 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

2
alloy/Data/Generics/Alloy/Route.hs
View File

@ -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 <http://www.gnu.org/licenses/>.
-}
module Data.Generics.Polyplate.Route
module Data.Generics.Alloy.Route
(Route, routeModify, routeGet, routeSet, (@->), identityRoute, routeId, routeList,
makeRoute, routeDataMap, routeDataSet)
where

101
alloy/Data/Generics/Alloy/Schemes.hs
View File

@ -17,12 +17,12 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-}
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

12
backends/BackendPasses.hs
View File

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

2
checks/ArrayUsageCheck.hs
View File

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

8
checks/Check.hs
View File

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

109
checks/CheckFramework.hs
View File

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

2
checks/UsageCheckUtils.hs
View File

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

2
flow/FlowGraph.hs
View File

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

2
flow/FlowGraphTest.hs
View File

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

2
flow/FlowUtils.hs
View File

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

16
frontends/OccamCheckTypes.hs
View File

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

74
frontends/OccamInferTypes.hs
View File

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

5
frontends/OccamPasses.hs
View File

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

12
frontends/OccamPassesTest.hs
View File

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

32
frontends/OccamTypesTest.hs
View File

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

20
frontends/RainTypes.hs
View File

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

20
pass/Pass.hs
View File

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

136
pass/Traversal.hs
View File

@ -21,22 +21,35 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
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)

6
pregen/GenNavAST.hs
View File

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

4
transformations/ImplicitMobility.hs
View File

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

21
transformations/SimplifyAbbrevs.hs
View File

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

6
transformations/SimplifyAbbrevsTest.hs
View File

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

34
transformations/SimplifyExprs.hs
View File

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

7
transformations/SimplifyProcs.hs
View File

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

4
transformations/SimplifyTypesTest.hs
View File

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

38
transformations/Unnest.hs
View File

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