diff options
Diffstat (limited to 'src/GF')
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 39 | ||||
| -rw-r--r-- | src/GF/Compile/Optimize.hs | 6 | ||||
| -rw-r--r-- | src/GF/Grammar/Macros.hs | 33 |
3 files changed, 35 insertions, 43 deletions
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 21cb35b7b..213eba760 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -20,8 +20,7 @@ -- - tables are type-annotated ----------------------------------------------------------------------------- -module GF.Compile.CheckGrammar ( - checkModule, inferLType, allOperDependencies, topoSortOpers) where +module GF.Compile.CheckGrammar(checkModule) where import GF.Infra.Ident import GF.Infra.Modules @@ -47,9 +46,9 @@ import Text.PrettyPrint checkModule :: [SourceModule] -> SourceModule -> Check SourceModule checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do checkRestrictedInheritance ms m + checkErr $ topoSortJments m js <- case mtype mo of - MTConcrete a -> do checkErr $ topoSortOpers $ allOperDependencies name (jments mo) - abs <- checkErr $ lookupModule gr a + MTConcrete a -> do abs <- checkErr $ lookupModule gr a checkCompleteGrammar gr (a,abs) m _ -> return (jments mo) js <- checkMap (checkInfo gr m) js @@ -275,35 +274,3 @@ linTypeOfType cnc m typ = do checkErr (lookupLincat cnc m c) >>= computeLType cnc [] ,return defLinType ] - --- | dependency check, detecting circularities and returning topo-sorted list - -allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])] -allOperDependencies m = allDependencies (==m) - -allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] -allDependencies ism b = - [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] - where - opersIn t = case t of - Q n c | ism n -> [c] - QC n c | ism n -> [c] - _ -> collectOp opersIn t - opty (Just ty) = opersIn ty - opty _ = [] - pts i = case i of - ResOper pty pt -> [pty,pt] - ResParam (Just ps) _ -> [Just t | (_,cont) <- ps, (_,_,t) <- cont] - CncCat pty _ _ -> [pty] - CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) - AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual - AbsCat (Just co) _ -> [Just ty | (_,_,ty) <- co] - _ -> [] - -topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] -topoSortOpers st = do - let eops = topoTest st - either - return - (\ops -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head ops))))) - eops diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index eb3fc8383..85195b516 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -46,8 +46,7 @@ optimizeModule opts ms mo@(name,mi) | mstatus mi == MSComplete = do mo1 <- case mtype mi of _ | isModRes mi -> do - let deps = allOperDependencies name (jments mi) - ids <- topoSortOpers deps + ids <- topoSortJments mo if OptExpand `Set.member` optim then do mi <- foldM evalOp mi ids return (name,mi) @@ -64,8 +63,7 @@ optimizeModule opts ms mo@(name,mi) gr = MGrammar $ mo : ms - evalOp mi i = do - info <- lookupTree showIdent i (jments mi) + evalOp mi (i,info) = do info' <- evalResInfo oopts gr (i,info) return (updateModule mi i info') diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index 016d8b3bb..799cd9ec5 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -21,6 +21,7 @@ module GF.Grammar.Macros where import GF.Data.Operations import GF.Data.Str import GF.Infra.Ident +import GF.Infra.Modules import GF.Grammar.Grammar import GF.Grammar.Values import GF.Grammar.Predef @@ -28,7 +29,7 @@ import GF.Grammar.Printer import Control.Monad (liftM, liftM2) import Data.Char (isDigit) -import Data.List (sortBy) +import Data.List (sortBy,nub) import Text.PrettyPrint typeForm :: Type -> (Context, Cat, [Term]) @@ -596,5 +597,31 @@ sortRec = sortBy ordLabel where (_,"s") -> GT (s1,s2) -> compare s1 s2 - - +-- | dependency check, detecting circularities and returning topo-sorted list + +allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] +allDependencies ism b = + [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] + where + opersIn t = case t of + Q n c | ism n -> [c] + QC n c | ism n -> [c] + _ -> collectOp opersIn t + opty (Just ty) = opersIn ty + opty _ = [] + pts i = case i of + ResOper pty pt -> [pty,pt] + ResParam (Just ps) _ -> [Just t | (_,cont) <- ps, (_,_,t) <- cont] + CncCat pty _ _ -> [pty] + CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) + AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual + AbsCat (Just co) _ -> [Just ty | (_,_,ty) <- co] + _ -> [] + +topoSortJments :: SourceModule -> Err [(Ident,Info)] +topoSortJments (m,mi) = do + is <- either + return + (\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) + (topoTest (allDependencies (==m) (jments mi))) + return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) |