Changed the pass mechanism to use a fixed list again rather than use the dependency graph

This fixes ticket #47 from Trac, which explains how using a dependency graph for passes was a bit too over the top, and led to unexpected results.  Under the "new" (the original!) system, the pass list is used as-is, but the dependencies are checked to make sure the pass list order isn't wrong.  In future we should also add back running the properties at the appropriate point (currently disabled).

pass/Pass.hs

@@ -82,6 +82,9 @@ instance Eq Property where
 instance Ord Property where
   compare x y = compare (propName x) (propName y)
 
+instance Show Property where
+  show = propName
+
 runPassR :: (A.AST -> PassMR A.AST) -> (A.AST -> PassM A.AST)
 runPassR p t 
            = do st <- get

pass/PassList.hs

@@ -20,9 +20,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module PassList (calculatePassList, getPassList) where
 
 import Control.Monad.Error
-import Data.Graph.Inductive
 import Data.List
-import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import BackendPasses
@@ -31,6 +29,7 @@ import CompState
 import Errors
 import GenerateC
 import GenerateCPPCSP
+import Metadata
 import OccamPasses
 import Pass
 import qualified Properties as Prop
@@ -59,7 +58,7 @@ filterPasses :: CompState -> [Pass] -> [Pass]
 filterPasses opts = filter (\p -> passEnabled p opts)
 
 getPassList :: CompState -> [Pass]
-getPassList optsPS = filterPasses optsPS $ concat
+getPassList optsPS = checkList $ filterPasses optsPS $ concat
                                 [ occamPasses
                                 , rainPasses
                                 , commonPasses optsPS
@@ -67,96 +66,41 @@ getPassList optsPS = filterPasses optsPS $ concat
                                 , genCPPCSPPasses
                                 ]
 
-calculatePassList :: (Die m, CSMR m) => m [Pass]
+calculatePassList :: CSMR m => m [Pass]
-calculatePassList
+calculatePassList = getCompState >>* getPassList
-  = do st <- getCompState
-       let rawList = getPassList st
-       case buildGraph (csSanityCheck st) rawList of
-         Left err -> dieReport (Nothing, "Error working out pass list: " ++ err)
-         Right g -> return $ graphToList (g :: Gr Pass ())
 
--- Note that the pass execution is "strict" -- that is, all passes
+--TODO put back the sanity check option to enable the property checking
--- are executed, it is only the order that is calculated.  In future,
--- providing we construct the post-conditions carefully, we could
--- have "lazy" passes where we only execute those that have a post-
--- condition that we need later on
-graphToList :: Graph gr => gr Pass () -> [Pass]
-graphToList = topsort'
 
-buildGraph :: forall gr. Graph gr => Bool -> [Pass] -> Either String (gr Pass ())
+-- | If something isn't right, it gives back a list containing a single pass
-buildGraph runProps passes
+-- that will give an error.
-                  = do checked <- checkedRelations
+checkList :: [Pass] -> [Pass]
-                       checkPassUnique
+checkList passes = case check [] passes of
-                       checkGraph
+    Left err -> [Pass {passCode = const $ dieP emptyMeta err
-                       nodes <- labelledNodes
+                      ,passName = "Pass List Error"
-                       edges <- edgeList checked
+                      ,passPre = Set.empty
-                       return $ mkGraph nodes edges
+                      ,passPost = Set.empty
+                      ,passEnabled = const True}
+                ]
+    Right ps -> ps
   where
-    prefixPropName :: String -> String
+    check :: [Pass] -> [Pass] -> Either String [Pass]
-    prefixPropName = ("_prop_" ++)
+    check prev [] = Right prev
-  
+    check prev (p:ps)
-    allProperties :: [Property] -- find all properties in the passes
+      = case filter givesPrereq ps of
-    allProperties = nub $ concatMap (\p -> Set.toList (passPre p) ++ Set.toList (passPost p)) passes
+          -- Check that our pre-requisites are not supplied by a later pass:
-  
+          (x:_) ->
-    propToPass :: Property -> Pass
+             Left $ "Pass order not correct; one of the pre-requisites"
-    propToPass prop = Pass {
+               ++ " for pass: " ++ (passName p) ++ " is supplied in a later"
-      passCode = if runProps then runPassR (\t -> propCheck prop t >> return t) else return
+               ++ " pass: " ++ (passName x) ++ ", pre-requisites in question"
-     ,passName = prefixPropName (propName prop)
+               ++ " are: " ++ show (Set.intersection (passPost x) (passPre p))
-     ,passPre  = Set.empty
+                -- Now check that someone supplied our pre-requisites:
-     ,passPost = Set.empty
+          [] -> if Set.null (passPre p) || any givesPrereq prev
-     ,passEnabled = const True}    
+                  then check (prev ++ [p]) ps
-  
+                  else Left $ "Pass order not correct; one of the pre-requisites"
-    passesAndProps :: [Pass]
+                   ++ " for pass: " ++ (passName p) ++ "is not supplied"
-    passesAndProps = passes ++ map propToPass allProperties
+                   ++ " by a prior pass, pre-requisites are: "
-  
+                   ++ show (passPre p)
-    checkPassUnique :: Either String ()
-    checkPassUnique = when (length (nub passesAndProps) /= length passesAndProps) $
-                        throwError "Not all pass-names were unique"
-  
-    -- Maps a property from those with it as a post-condition to those with it as a pre-condition
-    relations :: Map.Map Property (Set.Set Pass, Set.Set Pass)
-    relations = Map.fromListWith merge $ concatMap toRelation passes
       where
-        merge :: (Ord a, Ord b) => (Set.Set a, Set.Set b) -> (Set.Set a, Set.Set b) -> (Set.Set a, Set.Set b)
+        givesPrereq :: Pass -> Bool
-        merge (xa, xb) (ya, yb) = (Set.union xa ya, Set.union xb yb)
+        givesPrereq p' = not $ Set.null $
-        
+          Set.intersection (passPost p') (passPre p)
-        toRelation :: Pass -> [(Property, (Set.Set Pass, Set.Set Pass))]
-        toRelation pass = map toPost (Set.toList $ passPost pass) ++ map toPre (Set.toList $ passPre pass)
-          where
-            toPost :: Property -> (Property, (Set.Set Pass, Set.Set Pass))
-            toPost prop = (prop, (Set.singleton pass, Set.empty))
-            toPre :: Property -> (Property, (Set.Set Pass, Set.Set Pass))
-            toPre prop = (prop, (Set.empty, Set.singleton pass))
-
-    checkedRelations :: Either String (Map.Map Property (Set.Set Pass, Set.Set Pass))
-    checkedRelations = liftM Map.fromList $ mapM check $ Map.toList relations
-      where
-        check :: (Property, (Set.Set Pass, Set.Set Pass)) -> Either String (Property, (Set.Set Pass, Set.Set Pass))
-        check (prop, (post, pre))
-          = do when (Set.null post && not (Set.null pre)) $
-                 throwError $ "Property in dependency graph is required by a pass but not provided by any: "
-                   ++ show (propName prop)
-               return (prop, (post, pre)) --TODO this is an identity transformation, so just check separately
-               
-    checkGraph :: Either String ()
-    checkGraph = return () -- TODO check for cycles
-
-    nodeLabels :: Map.Map Pass Node
-    nodeLabels = Map.fromList $ zip passesAndProps [0..]
-
-    lookupPass :: Pass -> Either String Node
-    lookupPass p = transformEither ("Internal, should-be-impossible error in lookupPass " ++) id  $ Map.lookup p nodeLabels
-
-    lookupProp :: Property -> Either String Node
-    lookupProp p = transformEither ("Internal, should-be-impossible error in lookupProp " ++) id  $ Map.lookup (propToPass p) nodeLabels
-
-    labelledNodes :: Either String [LNode Pass]
-    labelledNodes = mapM (\p -> do {lp <- lookupPass p; return (lp, p)}) passesAndProps
-    
-    edgeList :: Map.Map Property (Set.Set Pass, Set.Set Pass) -> Either String [LEdge ()]
-    edgeList = concatMapM (\(prop, (froms, tos)) ->
-      do tos' <- mapM lookupPass (Set.toList tos)
-         froms' <- mapM lookupPass (Set.toList froms)
-         prop' <- lookupProp prop
-         return $ [(f, prop', ()) | f <- froms'] ++ [(prop', t, ()) | t <- tos']) . Map.toList
-