faster and correct dependency checking

src/compiler/api/GF/Compile/CheckGrammar.hs

@@ -53,8 +53,8 @@ checkModule opts cwd sgr mo@(m,mi) = do
                              abs <- lookupModule gr a
                              checkCompleteGrammar opts cwd gr (a,abs) mo
           _            -> return mo
-  infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
-  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
+  infos <- checkInModule cwd mi NoLoc empty $ topoSortJments mo
+  foldM (checkInfo opts cwd sgr) mo infos
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
@@ -71,7 +71,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
      let incld c   = Set.member c (Set.fromList incl)
      let illegal c = Set.member c (Set.fromList excl)
      let illegals = [(f,is) |
-           (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
+           (f,_,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
      case illegals of
        [] -> return ()
        cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$

src/compiler/api/GF/Data/Operations.hs

@@ -35,9 +35,6 @@ module GF.Data.Operations (
      prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
      numberedParagraphs, prConjList, prIfEmpty, wrapLines,
 
-     -- ** Topological sorting
-     topoTest, topoTest2,
-
      -- ** Misc
      readIntArg,
      iterFix,  chunks,
@@ -53,7 +50,6 @@ import Control.Monad (liftM,liftM2) --,ap
 import Control.Monad.Fix
 
 import GF.Data.ErrM
-import GF.Data.Relation
 import qualified Control.Monad.Fail as Fail
 
 infixr 5 +++
@@ -188,26 +184,6 @@ wrapLines n s@(c:cs) =
                      l = length w
             _ -> s -- give up!!
 
--- | Topological sorting with test of cyclicity
-topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
-topoTest = topologicalSort . mkRel'
-
--- | Topological sorting with test of cyclicity, new version /TH 2012-06-26
-topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
-topoTest2 g0 = maybe (Right cycles) Left (tsort g)
-  where
-    g = g0++[(n,[])|n<-nub (concatMap snd g0)\\map fst g0]
-
-    cycles = findCycles (mkRel' g)
-
-    tsort nes =
-      case partition (null.snd) nes of
-        ([],[]) -> Just []
-        ([],_) -> Nothing
-        (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
-            where leaves = map fst ns
-
-
 -- | Fix point iterator (for computing e.g. transitive closures or reachability)
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
 iterFix more start = iter start start

src/compiler/api/GF/Grammar/Grammar.hs

@@ -77,6 +77,7 @@ import GF.Data.Operations
 import PGF2(BindType(..),PGF)
 import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..))
 
+import Data.Graph
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
 import qualified Data.Map as Map
@@ -276,10 +277,11 @@ isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
 
 -- | all abstract modules sorted from least to most dependent
 allAbstracts :: Grammar -> [ModuleName]
-allAbstracts gr = 
- case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
-   Left  is     -> is
-   Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
+allAbstracts gr =
+ let scc = stronglyConnComp [(mn,mn,extends mo) | (mn,mo) <- modules gr, mtype mo == MTAbstract]
+ in case [mns | CyclicSCC mns <- scc] of
+      []     -> [mn | AcyclicSCC mn <- scc]
+      cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
 
 -- | the last abstract in dependency order (head of list)
 greatestAbstract :: Grammar -> Maybe ModuleName

src/compiler/api/GF/Grammar/Macros.hs

@@ -28,10 +28,11 @@ import GF.Grammar.Printer
 import Control.Monad.Identity(Identity(..))
 import qualified Data.Traversable as T(mapM)
 import qualified Data.Map as Map
-import Control.Monad (liftM, liftM2, liftM3)
+import Control.Monad (liftM, liftM2, liftM3, forM)
 import Data.List (sortBy,nub)
 import Data.Monoid
-import GF.Text.Pretty(render,(<+>),hsep,fsep)
+import Data.Graph
+import GF.Text.Pretty(render,(<+>),($$),hsep,fsep,vcat,nest)
 import qualified Control.Monad.Fail as Fail
 
 -- ** Functions for constructing and analysing source code terms.
@@ -538,16 +539,25 @@ sortRec = sortBy ordLabel where
 
 -- | dependency check, detecting circularities and returning topo-sorted list
 
-allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
+allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,Info,[Ident])]
 allDependencies ism b =
-  [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
+  [(f, i, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
   where
     opersIn t = case t of
       Q  (n,c) | ism n -> [c]
       QC (n,c) | ism n -> [c]
+      EPatt _ _ p -> opersInPatt p
+      T _ cs -> mconcatMap (\(p,t) -> opersInPatt p ++ opersIn t) cs
       _ -> collectOp opersIn t
+
+    opersInPatt p = case p of
+      PTilde t         -> opersIn t
+      PM (n,c) | ism n -> [c]
+      _ -> collectPattOp opersInPatt p
+
     opty (Just (L _ ty)) = opersIn ty
     opty _ = []
+
     pts i = case i of
       ResOper pty pt -> [pty,pt]
       ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
@@ -560,22 +570,14 @@ allDependencies ism b =
 
 topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
 topoSortJments (m,mi) = do
-  is <- either
-          return
-          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
-          (topoTest (allDependencies (==m) (jments mi)))
-  return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])
-
-topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
-topoSortJments2 (m,mi) = do
-  iss <- either
-           return
-           (\cyc -> raise (render ("circular definitions:"
-                                   <+> fsep (head cyc))))
-           (topoTest2 (allDependencies (==m) (jments mi)))
-  return
-    [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss]
-
+  let sccs = stronglyConnComp (map toNode (allDependencies (==m) (jments mi)))
+      cycles = [map fst jmts | CyclicSCC jmts <- sccs]
+  case cycles of
+    [] -> return [jmt | AcyclicSCC jmt <- sccs]
+    _  -> raise (render ("circular definitions:" $$
+                             nest 3 (vcat (map fsep cycles))))
+  where
+    toNode (id,info,deps) = ((id,info),id,deps)
 
 mkStrs p = case p of
  PAlt a b -> do

src/compiler/api/GF/Speech/CFGToFA.hs

@@ -20,7 +20,6 @@ import GF.Grammar.CFG
 --import GF.Infra.Ident (Ident)
 
 import GF.Data.Graph
---import GF.Data.Relation
 import GF.Speech.FiniteState
 --import GF.Speech.CFG