check for cyclic parameters, operations and dependent types

src/GF/Compile/CheckGrammar.hs

@@ -20,8 +20,7 @@
 --  - tables are type-annotated
 -----------------------------------------------------------------------------
 
-module GF.Compile.CheckGrammar (
+module GF.Compile.CheckGrammar(checkModule) where
-  checkModule, inferLType, allOperDependencies, topoSortOpers) 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)
+          MTConcrete a -> do abs <- checkErr $ lookupModule gr a
-                             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

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 <- topoSortJments mo
-                     ids <- topoSortOpers deps
                      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
+   evalOp mi (i,info) = do
-     info  <- lookupTree showIdent i (jments mi)
      info' <- evalResInfo oopts gr (i,info)
      return (updateModule mi i info')
 

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)]])

src/GFI.hs

@@ -10,8 +10,8 @@ import GF.Data.ErrM
 import GF.Grammar hiding (Ident)
 import GF.Grammar.Parser (runP, pExp)
 import GF.Compile.Rename
-import GF.Compile.CheckGrammar
 import GF.Compile.Concrete.Compute (computeConcrete)
+import GF.Compile.Concrete.TypeCheck (inferLType)
 import GF.Infra.Dependencies
 import GF.Infra.CheckM
 import GF.Infra.UseIO