diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs index 350e2c81c..34fc9fa44 100644 --- a/src/compiler/api/GF/Compile/CheckGrammar.hs +++ b/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:" $$ diff --git a/src/compiler/api/GF/Data/Operations.hs b/src/compiler/api/GF/Data/Operations.hs index 539b77c8f..ffd860976 100644 --- a/src/compiler/api/GF/Data/Operations.hs +++ b/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 diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs index 2ae64c5b7..c113fe8d3 100644 --- a/src/compiler/api/GF/Grammar/Grammar.hs +++ b/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 diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs index ad3adfd5d..004fcdd59 100644 --- a/src/compiler/api/GF/Grammar/Macros.hs +++ b/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 diff --git a/src/compiler/api/GF/Speech/CFGToFA.hs b/src/compiler/api/GF/Speech/CFGToFA.hs index 08b966354..a905c0c48 100644 --- a/src/compiler/api/GF/Speech/CFGToFA.hs +++ b/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