Improved interface and instance compilation.

Improved interface and instance compilation.
Restored an optimization of the optimizer: up to 4x faster now.

src/GF/Compile/Compile.hs

@@ -168,10 +168,11 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
   mo1   <- ioeErr $ rebuildModule mos mo
 
   mo1b  <- ioeErr $ extendModule mos mo1
-  ---- prDebug mo1b
+  ----  prDebug mo1b
 
   case mo1b of
-    (_,ModMod n) | not (isCompleteModule n) -> return (k,mo1b)
+    (_,ModMod n) | not (isCompleteModule n) -> do
+      return (k,mo1b)   -- refresh would fail, since not renamed
     _ -> do
       mo2:_ <- putp "  renaming " $ ioeErr $ renameModule mos mo1b
 

src/GF/Compile/Optimize.hs

@@ -29,8 +29,8 @@ evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
                Err [(Ident,SourceModInfo)]
 evalModule ms mo@(name,mod) = case mod of
 
-  ModMod (Module mt st fs me ops js) | st == MSComplete -> case mt of
+  ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
-    MTResource -> do
+    _ | isModRes m0 -> do
       let deps = allOperDependencies name js
       ids <- topoSortOpers deps
       MGrammar (mod' : _) <- foldM evalOp gr ids

src/GF/Compile/Rebuild.hs

@@ -32,7 +32,14 @@ rebuildModule ms mo@(i,mi) = do
           testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
           m' <- do
             js' <- extendMod False i0 (jments m1) (jments m)
-            return $ replaceJudgements m js'
+            --- to avoid double inclusions, in instance I of I0 = J0 ** ...
+            case extends m of
+              Nothing -> return $ replaceJudgements m js'
+              Just j0 -> do 
+                m0 <- lookupModMod gr j0
+                let notInM0 c = not $ isInBinTree (fst c) $ mapTree fst $ jments m0
+                let js2 = sorted2tree $ filter notInM0 $ tree2list js'
+                return $ replaceJudgements m js2
           return $ ModMod m'
         _ -> return mi
 
@@ -40,7 +47,7 @@ rebuildModule ms mo@(i,mi) = do
     ModWith mt stat ext ops -> do
       let insts = [(inf,inst) | OQualif _ inf inst <- ops]
       let infs  = map fst insts
-      let stat' = ifNull MSComplete (const MSIncomplete) 
+      let stat' = ifNull MSComplete (const MSIncomplete)
                     [i | i <- is, notElem i infs]
       testErr (stat' == MSComplete || stat == MSIncomplete) 
               ("module" +++ prt i +++ "remains incomplete")

src/GF/Grammar/Compute.hs

@@ -172,6 +172,10 @@ computeTerm gr = comp where
          _ -> return $ ExtR r' s'
 
      -- case-expand tables
+     T i@(TComp _) cs -> do
+       cs' <- mapPairsM (comp g) cs
+       return $ T i cs'
+
      T i cs -> do
        pty0 <- getTableType i
        ptyp <- comp g pty0

src/GF/Grammar/Refresh.hs

@@ -86,7 +86,7 @@ refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
 
 refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
 refreshModule (k,ms) mi@(i,m) = case m of
-    ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || mt == MTResource) -> do
+    ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || isModRes mo) -> do
       (k',js') <- foldM refreshRes (k,[]) $ tree2list js
       return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms)
     _ -> return (k, mi:ms)

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Wed Nov 12 13:30:08 CET 2003"
+module Today where today = "Thu Nov 13 17:50:30 CET 2003"