From 8f767ff0d4c8ea3462c189a110fc2d1cf86497c0 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Thu, 9 Apr 2009 15:36:37 +0000 Subject: [PATCH] Made all the imports of Data.Generics have an import list This makes sure that we catch all leftover instances of using SYB to do generic operations that we should be using Polyplate for instead. Most modules should only import Data, and possibly Typeable. --- Main.hs | 4 +- Makefile.am | 2 +- backends/AnalyseAsm.hs | 2 +- backends/GenerateC.hs | 7 +- backends/GenerateCBased.hs | 2 +- backends/GenerateCHP.hs | 2 +- backends/GenerateCPPCSP.hs | 6 +- backends/TLP.hs | 2 +- checks/Check.hs | 13 +++- checks/CheckFramework.hs | 4 +- checks/UsageCheckAlgorithms.hs | 5 +- common/Errors.hs | 2 +- common/EvalLiterals.hs | 2 +- common/PrettyShow.hs | 4 +- common/ShowCode.hs | 7 +- common/Types.hs | 2 +- data/CompState.hs | 2 +- data/Metadata.hs | 2 +- flow/FlowGraph.hs | 2 +- flow/FlowUtils.hs | 2 +- frontends/LexOccam.x | 2 +- frontends/LexRain.x | 2 +- frontends/OccamPasses.hs | 2 +- frontends/OccamTypes.hs | 2 +- frontends/ParseRain.hs | 2 +- frontends/RainPasses.hs | 2 +- frontends/RainTypes.hs | 2 +- frontends/TypeUnification.hs | 2 +- frontends/UnifyType.hs | 2 +- pass/Pass.hs | 2 +- pass/Properties.hs | 2 +- pass/Traversal.hs | 101 ++++++++++++++++++++++++++-- transformations/ImplicitMobility.hs | 2 +- transformations/SimplifyAbbrevs.hs | 2 +- transformations/SimplifyExprs.hs | 12 +--- transformations/SimplifyProcs.hs | 2 +- transformations/Unnest.hs | 34 ++++++---- 37 files changed, 179 insertions(+), 70 deletions(-) diff --git a/Main.hs b/Main.hs index 4df1eea..2da9bad 100644 --- a/Main.hs +++ b/Main.hs @@ -24,7 +24,7 @@ import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer import Data.Either -import Data.Generics +import Data.Generics (Data) import Data.Maybe import qualified Data.Set as Set import List @@ -459,6 +459,7 @@ compile mode fn (outHandles@(outHandle, _), headerName) ModeLex -> liftIO $ hPutStr outHandle $ pshow lexed ModeHTML -> liftIO $ hPutStr outHandle $ showTokens True lexed ModeParse -> liftIO $ hPutStr outHandle $ pshow ast1 +{- ModeFlowGraph -> do procs <- findAllProcesses let fs :: Data t => t -> PassM String @@ -476,6 +477,7 @@ compile mode fn (outHandles@(outHandle, _), headerName) = map (transformMaybe $ \(x,_,_) -> x) graphs -- TODO: output each process to a separate file, rather than just taking the first: liftIO $ hPutStr outHandle $ head $ map makeFlowGraphInstr (catMaybes graphsTyped) +-} ModeCompile -> do progress "Passes:" diff --git a/Makefile.am b/Makefile.am index e3b1ba4..3f5eddc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,5 +1,5 @@ GHC_OPTS = \ - -fcontext-stack=200 \ + -fcontext-stack=400 \ -fwarn-deprecations \ -fwarn-duplicate-exports \ -fwarn-incomplete-record-updates \ diff --git a/backends/AnalyseAsm.hs b/backends/AnalyseAsm.hs index 4ebda6d..285c977 100644 --- a/backends/AnalyseAsm.hs +++ b/backends/AnalyseAsm.hs @@ -30,7 +30,7 @@ module AnalyseAsm ( import Control.Arrow import Control.Monad.State import Data.Char -import Data.Generics +import Data.Generics (Data, Typeable) import Data.List import qualified Data.Map as Map import Data.Maybe diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 187c002..e9ba248 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -41,7 +41,7 @@ module GenerateC ) where import Data.Char -import Data.Generics +import Data.Generics (Data) import Data.List import qualified Data.Map as Map import Data.Maybe @@ -63,6 +63,7 @@ import Pass import qualified Properties as Prop import ShowCode import TLP +import Traversal import Types import TypeSizes import Utils @@ -181,11 +182,11 @@ cgenTopLevel headerName s = A.nameName n `elem` (csOriginalTopLevelProcs cs) tellToHeader $ sequence_ $ map (call genForwardDeclaration) - (listify isTopLevelSpec s) + (listifyDepth isTopLevelSpec s) -- Things like lifted wrapper_procs we still need to forward-declare, -- but we do it in the C file, not in the header: sequence_ $ map (call genForwardDeclaration) - (listify (not . isTopLevelSpec) s) + (listifyDepth (not . isTopLevelSpec) s) tell ["#include \"", dropPath headerName, "\"\n"] diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 690cdc6..1cee60b 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -22,7 +22,7 @@ module GenerateCBased where import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer hiding (tell) -import Data.Generics +import Data.Generics (Data) import Data.List import System.IO diff --git a/backends/GenerateCHP.hs b/backends/GenerateCHP.hs index b2fcc6f..859a666 100644 --- a/backends/GenerateCHP.hs +++ b/backends/GenerateCHP.hs @@ -42,7 +42,7 @@ module GenerateCHP where import Control.Monad.State import Control.Monad.Trans import Data.Char -import Data.Generics +import Data.Generics (Data, showConstr, toConstr) import Data.List import Data.Maybe import System.IO diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index 66f1a89..2917af0 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -32,7 +32,7 @@ module GenerateCPPCSP (cppcspPrereq, cppgenOps, generateCPPCSP, genCPPCSPPasses) import Control.Monad.State import Data.Char -import Data.Generics +import Data.Generics (Data) import Data.List import Data.Maybe import qualified Data.Set as Set @@ -144,11 +144,11 @@ cppgenTopLevel headerName s = A.nameName n `elem` (csOriginalTopLevelProcs cs) tellToHeader $ sequence_ $ map (call genForwardDeclaration) - (listify isTopLevelSpec s) + (listifyDepth isTopLevelSpec s) -- Things like lifted wrapper_procs we still need to forward-declare, -- but we do it in the C file, not in the header: sequence_ $ map (call genForwardDeclaration) - (listify (\sp@(A.Specification _ n _) + (listifyDepth (\sp@(A.Specification _ n _) -> not (isTopLevelSpec sp) && A.nameName n `notElem` map fst (csExternals cs)) s) diff --git a/backends/TLP.hs b/backends/TLP.hs index 8e99cb9..0bcb824 100644 --- a/backends/TLP.hs +++ b/backends/TLP.hs @@ -20,7 +20,7 @@ with this program. If not, see . module TLP where import Control.Monad.State -import Data.Generics +import Data.Generics (Data, Typeable) import Data.List import Data.Maybe diff --git a/checks/Check.hs b/checks/Check.hs index 6f768fc..19b4666 100644 --- a/checks/Check.hs +++ b/checks/Check.hs @@ -25,7 +25,7 @@ module Check (checkInitVarPass, usageCheckPass, checkUnusedVar) where import Control.Monad.Identity import Control.Monad.State import Control.Monad.Trans -import Data.Generics +import Data.Generics (Data) import Data.Graph.Inductive hiding (mapSnd) import Data.List hiding (union) import qualified Data.Map as Map @@ -104,8 +104,15 @@ followBK = map followBK' (concat $ mapMaybe (flip Map.lookup m) (Set.toList $ next `Set.difference` prev)) where - next = Set.fromList $ map Var $ listify (const True :: A.Variable -> Bool) bk + next = Set.fromList $ map Var $ concatMap allVarsInBK bk +allVarsInBK :: BackgroundKnowledge -> [A.Variable] +allVarsInBK (Equal a b) = listifyDepth (const True) a + ++ listifyDepth (const True) b +allVarsInBK (LessThanOrEqual a b) = listifyDepth (const True) a + ++ listifyDepth (const True) b +allVarsInBK (RepBoundsIncl v a b) = v : (listifyDepth (const True) a + ++ listifyDepth (const True) b) data And a = And [a] data Or a = Or [a] @@ -268,7 +275,7 @@ addBK mp mp2 g nid n makeMap :: And BackgroundKnowledge -> Map.Map Var (And BackgroundKnowledge) makeMap (And bks) = Map.fromListWith mappend $ concat - [zip (map Var $ listify (const True) bk) (repeat $ noAnd bk) | bk <- bks] + [zip (map Var $ allVarsInBK bk) (repeat $ noAnd bk) | bk <- bks] convValues :: Or (Map.Map Var (And BackgroundKnowledge)) convValues = Or $ map (Map.fromListWith mappend) $ diff --git a/checks/CheckFramework.hs b/checks/CheckFramework.hs index 65b371a..8cb6f1a 100644 --- a/checks/CheckFramework.hs +++ b/checks/CheckFramework.hs @@ -26,7 +26,7 @@ module CheckFramework (CheckOptM, CheckOptASTM, forAnyASTTopDown, forAnyASTStruc import Control.Monad.Reader import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import Data.Graph.Inductive hiding (apply) import Data.List import qualified Data.Map as Map @@ -486,7 +486,7 @@ runChecks (CheckOptM m) x = execStateT m (CheckOptData {ast = x, parItems = Noth nextVarsTouched = Map.empty, flowGraphRootsTerms = Nothing, lastValidMeta = emptyMeta}) >>* ast runChecksPass :: CheckOptM () -> Pass A.AST -runChecksPass c = pass "" [] [] (mkM (runChecks c)) +runChecksPass c = pass "" [] [] (runChecks c) --getParItems :: CheckOptM (ParItems ()) --getParItems = CheckOptM (\d -> Right (d, fromMaybe (generateParItems $ ast d) (parItems d))) diff --git a/checks/UsageCheckAlgorithms.hs b/checks/UsageCheckAlgorithms.hs index 58b16fb..67f1219 100644 --- a/checks/UsageCheckAlgorithms.hs +++ b/checks/UsageCheckAlgorithms.hs @@ -19,7 +19,7 @@ with this program. If not, see . module UsageCheckAlgorithms (checkPar, findConstraints, findReachDef, joinCheckParFunctions) where import Control.Monad -import Data.Generics +import Data.Generics (Data) import Data.Graph.Inductive import Data.List import qualified Data.Map as Map @@ -30,6 +30,7 @@ import qualified AST as A import FlowAlgorithms import FlowGraph import Metadata +import Traversal import Types import UsageCheckUtils import Utils @@ -203,7 +204,7 @@ findConstraints graph startNode processNode (n, e) nodeVal curAgg = case fmap getNodeData $ lab graph n of Just u -> let overlapsWithWritten e = not $ null $ intersect - (listify (const True) e) + (listifyDepth (const True) $ snd e) [v | Var v <- Map.keys $ writtenVars $ nodeVars u] valFilt = filter (not . overlapsWithWritten) $ nub $ nodeVal ++ (case e of diff --git a/common/Errors.hs b/common/Errors.hs index 008fafb..dea3bfa 100644 --- a/common/Errors.hs +++ b/common/Errors.hs @@ -23,7 +23,7 @@ module Errors (checkJust, Die(..), import Control.Monad.Error import Control.Monad.Trans -import Data.Generics +import Data.Generics (Data, Typeable) import Data.List import System.IO import System.IO.Error diff --git a/common/EvalLiterals.hs b/common/EvalLiterals.hs index f4ee0ac..eca05fd 100644 --- a/common/EvalLiterals.hs +++ b/common/EvalLiterals.hs @@ -23,7 +23,7 @@ import Control.Monad.Error import Control.Monad.Identity import Control.Monad.State import Data.Char -import Data.Generics +import Data.Generics (Data, Typeable) import Data.Int import Data.Maybe import Data.Word diff --git a/common/PrettyShow.hs b/common/PrettyShow.hs index f3541de..3305d26 100644 --- a/common/PrettyShow.hs +++ b/common/PrettyShow.hs @@ -29,7 +29,7 @@ with this program. If not, see . -- (via the 'extCode' function) to print out data, otherwise it acts -- like pshow. Note that because pshowCode chooses the appropriate -- language based on the 'csFrontend' in 'CompState', it is inside the CSM monad. -module PrettyShow (pshow, pshowCode) where +module PrettyShow (pshow) where import Control.Monad.State import Data.Generics @@ -154,6 +154,7 @@ doAny extFunc = extFunc ( pshow :: Data a => a -> String pshow x = render $ doAny id x +{- pshowCode :: (Data a, CSMR m) => a -> m String pshowCode c = do st <- getCompState case csFrontend st of @@ -164,3 +165,4 @@ pshowCode c = do st <- getCompState extOccam f = extCode f showOccam extRain :: forall a. (Data a, Typeable a) => (a -> Doc) -> (a -> Doc) extRain f = extCode f showRain +-} diff --git a/common/ShowCode.hs b/common/ShowCode.hs index bbb80f3..85b24e7 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -33,11 +33,11 @@ with this program. If not, see . -- My plan for testing was to take each of the cgtests, and parse it in to AST_A. Then print AST_A using this -- module, and feed it back in to the parser to get AST_B. Then check if AST_A and AST_B are equal. -module ShowCode (showCode, ShowOccam(..), showOccam, ShowRain(..), showRain, formatCode, extCode) where +module ShowCode (showCode, ShowOccam(..), showOccam, ShowRain(..), showRain, formatCode) where import Control.Monad.State import Control.Monad.Writer -import Data.Generics +import Data.Generics (Data, gshow) import Data.List import qualified Data.Map as Map import Text.PrettyPrint.HughesPJ hiding (space, colon, semi) @@ -711,6 +711,7 @@ instance ShowRain a => ShowRain [a] where -- ShowOccam\/ShowRain implementation. But since to add a type to the ShowOccam\/ShowRain -- classes you have to provide a specific instance above anyway, I don't think that adding -- one more line while you're at it is too bad. +{- extCode :: (Data b, Typeable b) => (b -> Doc) -> (forall a. (ShowOccam a, ShowRain a) => a -> String) -> (b -> Doc) extCode q f = q `extQ` (text . (f :: A.Expression -> String)) @@ -723,4 +724,4 @@ extCode q f = q `extQ` (text . (f :: A.Variable -> String)) --TODO -- `ext1Q` (text . (f :: (Data c, ShowOccam c) => A.Structured c -> String)) - +-} diff --git a/common/Types.hs b/common/Types.hs index 3060699..1daf5c0 100644 --- a/common/Types.hs +++ b/common/Types.hs @@ -41,7 +41,7 @@ module Types import Control.Monad.State import Data.Char -import Data.Generics +import Data.Generics (Data) import qualified Data.Map as Map import Data.Maybe import Data.List diff --git a/data/CompState.hs b/data/CompState.hs index beb4201..4785ccf 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -23,7 +23,7 @@ import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer -import Data.Generics +import Data.Generics (Data, Typeable) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe diff --git a/data/Metadata.hs b/data/Metadata.hs index 9a859e4..58718f5 100644 --- a/data/Metadata.hs +++ b/data/Metadata.hs @@ -21,7 +21,7 @@ module Metadata where {-! global : Haskell2Xml !-} -import Data.Generics +import Data.Generics (Data, Typeable, listify) import Data.List import Numeric import Text.Printf diff --git a/flow/FlowGraph.hs b/flow/FlowGraph.hs index a0dfdd6..7c8e701 100644 --- a/flow/FlowGraph.hs +++ b/flow/FlowGraph.hs @@ -46,7 +46,7 @@ module FlowGraph (AlterAST(..), EdgeLabel(..), FNode, FlowGraph, FlowGraph', Gra import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import Data.Graph.Inductive hiding (run) import Data.Maybe diff --git a/flow/FlowUtils.hs b/flow/FlowUtils.hs index a6dc333..bb06678 100644 --- a/flow/FlowUtils.hs +++ b/flow/FlowUtils.hs @@ -21,7 +21,7 @@ module FlowUtils where import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State -import Data.Generics +import Data.Generics (Data, Typeable) import Data.Graph.Inductive hiding (run) import qualified AST as A diff --git a/frontends/LexOccam.x b/frontends/LexOccam.x index b7ce490..8860b0f 100644 --- a/frontends/LexOccam.x +++ b/frontends/LexOccam.x @@ -21,7 +21,7 @@ with this program. If not, see . module LexOccam where import Control.Monad.Error -import Data.Generics +import Data.Generics (Data, Typeable) import Errors import Metadata diff --git a/frontends/LexRain.x b/frontends/LexRain.x index 8048b95..2fe4e20 100644 --- a/frontends/LexRain.x +++ b/frontends/LexRain.x @@ -20,7 +20,7 @@ with this program. If not, see . -- | Lexically analyse Rain code. module LexRain where -import Data.Generics +import Data.Generics (Data, Typeable) import Metadata } diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index 9a72ebb..594046d 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -20,7 +20,7 @@ with this program. If not, see . module OccamPasses (occamPasses, foldConstants, checkConstants) where import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import Data.List import qualified Data.Sequence as Seq import qualified Data.Foldable as F diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index 528a60b..841d5b4 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -23,7 +23,7 @@ import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State import Data.Function (on) -import Data.Generics +import Data.Generics (Data) import Data.IORef import Data.List import qualified Data.Map as Map diff --git a/frontends/ParseRain.hs b/frontends/ParseRain.hs index 3c422c2..ecd8fc0 100644 --- a/frontends/ParseRain.hs +++ b/frontends/ParseRain.hs @@ -21,7 +21,7 @@ module ParseRain where import Control.Monad (liftM) import Control.Monad.State (MonadState, liftIO, get, put) -import Data.Generics +import Data.Generics (Data) import Data.List import Data.Maybe import qualified IO diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index 208cad2..ece4a0b 100644 --- a/frontends/RainPasses.hs +++ b/frontends/RainPasses.hs @@ -20,7 +20,7 @@ with this program. If not, see . module RainPasses where import Control.Monad.State -import Data.Generics +import Data.Generics -- TODO change this module to use Polyplate import Data.List import qualified Data.Map as Map import Data.Maybe diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 5ba2673..79a5a2f 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -19,7 +19,7 @@ with this program. If not, see . module RainTypes (constantFoldPass, performTypeUnification) where import Control.Monad.State -import Data.Generics +import Data.Generics (Data, showConstr, toConstr) import Data.List import qualified Data.Map as Map import Data.Maybe diff --git a/frontends/TypeUnification.hs b/frontends/TypeUnification.hs index 05d3d0c..2a318c0 100644 --- a/frontends/TypeUnification.hs +++ b/frontends/TypeUnification.hs @@ -21,7 +21,7 @@ module TypeUnification where import Control.Monad import Control.Monad.State import Control.Monad.Trans -import Data.Generics +import Data.Generics (Data, Typeable) import qualified Data.Map as Map import Data.Maybe import Data.IORef diff --git a/frontends/UnifyType.hs b/frontends/UnifyType.hs index d777ff0..d56f9a1 100644 --- a/frontends/UnifyType.hs +++ b/frontends/UnifyType.hs @@ -18,7 +18,7 @@ with this program. If not, see . module UnifyType where -import Data.Generics +import Data.Generics (Data, Typeable) import Data.IORef import qualified AST as A diff --git a/pass/Pass.hs b/pass/Pass.hs index 58bc81e..7e3ec41 100644 --- a/pass/Pass.hs +++ b/pass/Pass.hs @@ -22,7 +22,7 @@ module Pass where import Control.Monad.Error import Control.Monad.State import Control.Monad.Writer -import Data.Generics +import Data.Generics (Constr, Data) import Data.Generics.Polyplate import Data.List import Data.Ord diff --git a/pass/Properties.hs b/pass/Properties.hs index d05be71..a907d69 100644 --- a/pass/Properties.hs +++ b/pass/Properties.hs @@ -69,7 +69,7 @@ module Properties where import Control.Monad.Writer -import Data.Generics +import Data.Generics -- TODO stop this module using SYB import Data.Int import Data.List import qualified Data.Map as Map diff --git a/pass/Traversal.hs b/pass/Traversal.hs index f443c88..f7ed0bb 100644 --- a/pass/Traversal.hs +++ b/pass/Traversal.hs @@ -22,13 +22,14 @@ module Traversal ( TransformM, Transform, TransformStructured, TransformStructured' , CheckM, Check , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct - , applyBottomUpMS + , ExtOpQS, extOpQS + , applyBottomUpMS, ASTStructured , module Data.Generics.Polyplate , module Data.Generics.Polyplate.Schemes ) where import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import Data.Generics.Polyplate import Data.Generics.Polyplate.Schemes @@ -68,6 +69,57 @@ type ExtOpMSP opT = ExtOpMS PassM opT type PassOnStruct = PassOnOps (ExtOpMSP BaseOp) type PassASTOnStruct = PassASTOnOps (ExtOpMSP BaseOp) +class (PolyplateM (A.Structured a) () opsM m + ,PolyplateM (A.Structured a) opsM () m + ,PolyplateSpine (A.Structured a) opsQ () r + ,PolyplateSpine (A.Structured a) () opsQ r + ,Data a + ,Monad m + ) => ASTStructured a opsM m opsQ r + +instance (PolyplateM (A.Structured ()) () opsM m + ,PolyplateM (A.Structured ()) opsM () m + ,PolyplateSpine (A.Structured ()) opsQ () r + ,PolyplateSpine (A.Structured ()) () opsQ r + ,Monad m) => ASTStructured () opsM m opsQ r + +instance (PolyplateM (A.Structured A.Alternative) () opsM m + ,PolyplateM (A.Structured A.Alternative) opsM () m + ,PolyplateSpine (A.Structured A.Alternative) opsQ () r + ,PolyplateSpine (A.Structured A.Alternative) () opsQ r + ,Monad m) => ASTStructured A.Alternative opsM m opsQ r + +instance (PolyplateM (A.Structured A.Choice) () opsM m + ,PolyplateM (A.Structured A.Choice) opsM () m + ,PolyplateSpine (A.Structured A.Choice) opsQ () r + ,PolyplateSpine (A.Structured A.Choice) () opsQ r + ,Monad m) => ASTStructured A.Choice opsM m opsQ r + +instance (PolyplateM (A.Structured A.ExpressionList) () opsM m + ,PolyplateM (A.Structured A.ExpressionList) opsM () m + ,PolyplateSpine (A.Structured A.ExpressionList) opsQ () r + ,PolyplateSpine (A.Structured A.ExpressionList) () opsQ r + ,Monad m) => ASTStructured A.ExpressionList opsM m opsQ r + +instance (PolyplateM (A.Structured A.Option) () opsM m + ,PolyplateM (A.Structured A.Option) opsM () m + ,PolyplateSpine (A.Structured A.Option) opsQ () r + ,PolyplateSpine (A.Structured A.Option) () opsQ r + ,Monad m) => ASTStructured A.Option opsM m opsQ r + +instance (PolyplateM (A.Structured A.Process) () opsM m + ,PolyplateM (A.Structured A.Process) opsM () m + ,PolyplateSpine (A.Structured A.Process) opsQ () r + ,PolyplateSpine (A.Structured A.Process) () opsQ r + ,Monad m) => ASTStructured A.Process opsM m opsQ r + +instance (PolyplateM (A.Structured A.Variant) () opsM m + ,PolyplateM (A.Structured A.Variant) opsM () m + ,PolyplateSpine (A.Structured A.Variant) opsQ () r + ,PolyplateSpine (A.Structured A.Variant) () opsQ r + ,Monad m) => ASTStructured A.Variant opsM m opsQ r + + extOpMS :: forall m opT op0T. (PolyplateM (A.Structured ()) () op0T m, PolyplateM (A.Structured A.Alternative) () op0T m, @@ -86,9 +138,7 @@ extOpMS :: forall m opT op0T. opT -> -- Pairing the next two arguments allows us to apply this function infix: (op0T, -- just a type witness - forall t. (Data t, PolyplateM (A.Structured t) () op0T m - , PolyplateM (A.Structured t) op0T () m) => - A.Structured t -> m (A.Structured t)) -> + forall t. ASTStructured t op0T m () () => A.Structured t -> m (A.Structured t)) -> ExtOpMS m opT extOpMS ops (_, f) = ops @@ -100,6 +150,47 @@ extOpMS ops (_, f) `extOpM` (f :: A.Structured A.Alternative -> m (A.Structured A.Alternative)) `extOpM` (f :: A.Structured () -> m (A.Structured ())) +type ExtOpQS r opT = + (A.Structured () -> r, + (A.Structured A.Alternative -> r, + (A.Structured A.Choice -> r, + (A.Structured A.ExpressionList -> r, + (A.Structured A.Option -> r, + (A.Structured A.Process -> r, + (A.Structured A.Variant -> r, + opT))))))) + +extOpQS :: forall m opT op0T r. + (PolyplateSpine (A.Structured ()) () op0T r, + PolyplateSpine (A.Structured A.Alternative) () op0T r, + PolyplateSpine (A.Structured A.Choice) () op0T r, + PolyplateSpine (A.Structured A.ExpressionList) () op0T r, + PolyplateSpine (A.Structured A.Option) () op0T r, + PolyplateSpine (A.Structured A.Process) () op0T r, + PolyplateSpine (A.Structured A.Variant) () op0T r, + PolyplateSpine (A.Structured ()) op0T () r, + PolyplateSpine (A.Structured A.Alternative) op0T () r, + PolyplateSpine (A.Structured A.Choice) op0T () r, + PolyplateSpine (A.Structured A.ExpressionList) op0T () r, + PolyplateSpine (A.Structured A.Option) op0T () r, + PolyplateSpine (A.Structured A.Process) op0T () r, + PolyplateSpine (A.Structured A.Variant) op0T () r) => + opT -> + -- Pairing the next two arguments allows us to apply this function infix: + (op0T, -- just a type witness + forall t. ASTStructured t () PassM op0T r => A.Structured t -> r) -> + ExtOpQS r opT +extOpQS ops (_, f) + = ops + `extOpQ` (f :: A.Structured A.Variant -> r) + `extOpQ` (f :: A.Structured A.Process -> r) + `extOpQ` (f :: A.Structured A.Option -> r) + `extOpQ` (f :: A.Structured A.ExpressionList -> r) + `extOpQ` (f :: A.Structured A.Choice -> r) + `extOpQ` (f :: A.Structured A.Alternative -> r) + `extOpQ` (f :: A.Structured () -> r) + + applyBottomUpMS :: (PolyplateM t (ExtOpMSP BaseOp) () PassM) => (forall a. (Data a, PolyplateM (A.Structured a) () (ExtOpMSP BaseOp) PassM) => (A.Structured a -> PassM (A.Structured a))) diff --git a/transformations/ImplicitMobility.hs b/transformations/ImplicitMobility.hs index 59c7eb1..8841acb 100644 --- a/transformations/ImplicitMobility.hs +++ b/transformations/ImplicitMobility.hs @@ -20,7 +20,7 @@ module ImplicitMobility (implicitMobility, mobiliseArrays, inferDeref) where import Control.Monad import Control.Monad.Trans -import Data.Generics +import Data.Generics (Data) import Data.Graph.Inductive import Data.Graph.Inductive.Query.DFS import qualified Data.Map as Map diff --git a/transformations/SimplifyAbbrevs.hs b/transformations/SimplifyAbbrevs.hs index 4211a58..fece9c6 100644 --- a/transformations/SimplifyAbbrevs.hs +++ b/transformations/SimplifyAbbrevs.hs @@ -25,7 +25,7 @@ module SimplifyAbbrevs ( ) where import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index c4cfff0..4b0a278 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -20,7 +20,7 @@ with this program. If not, see . module SimplifyExprs where import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import qualified Data.Map as Map import qualified AST as A @@ -86,17 +86,11 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs" vpToSeq :: Meta -> A.Name -> [A.Variable] -> Either (A.Structured A.ExpressionList) A.Process -> A.Process vpToSeq m n vs (Left el) = A.Seq m $ vpToSeq' el vs - vpToSeq _ n vs (Right p) = subst p + vpToSeq _ n vs (Right p) = applyBottomUp doAssignSubst p where - subst :: Data t => t -> t - subst = doGenericSubst `extT` doAssignSubst - - doGenericSubst :: Data t => t -> t - doGenericSubst = gmapT subst `extT` (id :: String -> String) `extT` (id :: Meta -> Meta) - doAssignSubst :: A.Process -> A.Process doAssignSubst ass@(A.Assign m [A.Variable _ dest] el) = if (A.nameName dest == A.nameName n) then (A.Assign m vs el) else ass - doAssignSubst p = doGenericSubst p + doAssignSubst p = p vpToSeq' :: A.Structured A.ExpressionList -> [A.Variable] -> A.Structured A.Process diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 54837ae..5b4cf02 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -20,7 +20,7 @@ with this program. If not, see . module SimplifyProcs (simplifyProcs, fixLowReplicators) where import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import qualified Data.Set as Set import qualified AST as A diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index a9ba75f..9551fb8 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -21,10 +21,11 @@ module Unnest (unnest, removeNesting) where import Control.Monad.Identity import Control.Monad.State -import Data.Generics +import Data.Generics (Data) import Data.List import qualified Data.Map as Map import Data.Maybe +import Data.Tree import qualified AST as A import CompState @@ -44,28 +45,37 @@ unnest = ] type NameMap = Map.Map String A.Name +type FreeNameOps = ExtOpQ NameMap (ExtOpQ NameMap (ExtOpQS NameMap BaseOp) A.Name) A.SpecType -- | Get the set of free names within a block of code. -freeNamesIn :: Data t => t -> NameMap -freeNamesIn = doGeneric - `extQ` (ignore :: String -> NameMap) - `extQ` (ignore :: Meta -> NameMap) - `extQ` doName `ext1Q` doStructured `extQ` doSpecType +freeNamesIn :: PolyplateSpine t FreeNameOps () NameMap => t -> NameMap +freeNamesIn = flattenTree . recurse where - doGeneric :: Data t => t -> NameMap - doGeneric n = Map.unions $ gmapQ freeNamesIn n + flattenTree :: Tree (Maybe NameMap) -> NameMap + flattenTree = foldl Map.union Map.empty . catMaybes . flatten + + ops :: FreeNameOps + ops = baseOp `extOpQS` (ops, doStructured) `extOpQ` doName `extOpQ` doSpecType + recurse :: PolyplateSpine t FreeNameOps () NameMap => t -> Tree (Maybe NameMap) + recurse = transformSpine ops () + descend :: PolyplateSpine t () FreeNameOps NameMap => t -> Tree (Maybe NameMap) + descend = transformSpine () ops + ignore :: t -> NameMap ignore s = Map.empty doName :: A.Name -> NameMap doName n = Map.singleton (A.nameName n) n - doStructured :: Data a => A.Structured a -> NameMap + doStructured :: (Data a, PolyplateSpine (A.Structured a) () FreeNameOps NameMap + , PolyplateSpine (A.Structured a) FreeNameOps () NameMap) + => A.Structured a -> NameMap doStructured (A.Spec _ spec s) = doSpec spec s - doStructured s = doGeneric s + doStructured s = flattenTree $ descend s - doSpec :: Data t => A.Specification -> t -> NameMap + doSpec :: (PolyplateSpine t () FreeNameOps NameMap + ,PolyplateSpine t FreeNameOps () NameMap) => A.Specification -> t -> NameMap doSpec (A.Specification _ n st) child = Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child where @@ -74,7 +84,7 @@ freeNamesIn = doGeneric doSpecType :: A.SpecType -> NameMap doSpecType (A.Proc _ _ fs p) = Map.difference (freeNamesIn p) (freeNamesIn fs) doSpecType (A.Function _ _ _ fs vp) = Map.difference (freeNamesIn vp) (freeNamesIn fs) - doSpecType st = doGeneric st + doSpecType st = flattenTree $ descend st -- | Replace names. --