From c330cac1db47bbf5d90fbfbb215797c1dda186ae Mon Sep 17 00:00:00 2001
From: krasimir <krasimir@chalmers.se>
Date: Wed, 28 Oct 2009 17:44:50 +0000
Subject: check for cyclic parameters, operations and dependent types

---
 src/GF/Compile/CheckGrammar.hs | 39 +++------------------------------------
 src/GF/Compile/Optimize.hs     |  6 ++----
 2 files changed, 5 insertions(+), 40 deletions(-)

(limited to 'src/GF/Compile')

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')
 
-- 
cgit v1.2.3