compilation of functors

src/GF/Compile/CheckGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/06 22:00:37 $ 
+-- > CVS $Date: 2005/11/11 23:24:33 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.30 $
+-- > CVS $Revision: 1.31 $
 --
 -- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
 --
@@ -148,6 +148,7 @@ checkCompleteGrammar abs cnc = do
          checkWarn $ "Warning: no linearization of" +++ prt c
          return js
      AbsCat (Yes _) _ -> case lookupIdent c js of
+       Ok (AnyInd _ _) -> return js
        Ok (CncCat (Yes _) _ _) -> return js
        Ok (CncCat _ mt mp) -> do
          checkWarn $ 

src/GF/Compile/GrammarToCanon.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/22 08:52:02 $ 
+-- > CVS $Date: 2005/11/11 23:24:33 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.22 $
+-- > CVS $Revision: 1.23 $
 --
 -- Code generator from optimized GF source code to GFC.
 -----------------------------------------------------------------------------
@@ -31,6 +31,7 @@ import GF.Canon.MkGFC
 import qualified GF.Canon.PrintGFC as P
 
 import Control.Monad
+import Data.List (nub)
 
 -- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
 
@@ -82,7 +83,7 @@ redModInfo (c,info) = do
      os' <- mapM (\o -> case o of 
               OQualif q _ i -> liftM (OSimple q) (redIdent i)
               _ -> prtBad "cannot translate unqualified open in" c) $ opens m
-     return (e',os')
+     return (e',nub os')
    om = oSimple . openedModule --- normalizing away qualif
 
 redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]

src/GF/Compile/ModDeps.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:40 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.13 $
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
 --
 -- Check correctness of module dependencies. Incomplete.
 --
@@ -120,13 +120,17 @@ openInterfaces ds m = do
   let mods = iterFix (concatMap more) (more (m,undefined))
   return $ [i | (i,MTInterface) <- mods]
 
--- | this function finds out what modules are really needed in the canoncal gr.
+-- | this function finds out what modules are really needed in the canonical gr.
 -- its argument is typically a concrete module name
-requiredCanModules :: (Ord i, Show i) => MGrammar i f a -> i -> [i]
-requiredCanModules gr = nub . iterFix (concatMap more) . allExtends gr where
+requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i]
+requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
+  exts = allExtends gr c
+  ops  = if isSingle 
+         then map fst (modules gr) 
+         else iterFix (concatMap more) $ exts
   more i = errVal [] $ do
     m <- lookupModMod gr i
-    return $ extends m ++ [o | o <- map openedModule (opens m), notReuse o]
+    return $ extends m ++ [o | o <- map openedModule (opens m)]
   notReuse i = errVal True $ do
     m <- lookupModMod gr i
     return $ isModRes m -- to exclude reused Cnc and Abs from required

src/GF/Compile/ShellState.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/09 22:34:01 $ 
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.51 $
+-- > CVS $Revision: 1.52 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -313,9 +313,10 @@ purgeShellState sh = ShSt {
  where
    abstr = abstract sh
    concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed]
-   needed = nub $ concatMap (requiredCanModules (canModules sh)) acncs
+   isSingle = length (abstracts sh) == 1
+   needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs
    purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
-   acncs = maybe [] singleton (abstract sh) ++ map (snd . fst) (actualConcretes sh)
+   acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh)
 
 changeMain :: Maybe Ident -> ShellState -> Err ShellState
 changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s) = 
@@ -345,8 +346,8 @@ qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
 qualifTop gr (_,c) = (absId gr,c)
 
 stateGrammarOfLang :: ShellState -> Language -> StateGrammar
-stateGrammarOfLang st l = StGr {
-  absId    = maybe (identC "Abs") id (abstract st), ---
+stateGrammarOfLang st0 l = StGr {
+  absId    = err (const (identC "Abs")) id  $ M.abstractOfConcrete allCan l, ---
   cncId    = l,
   grammar  = can,
   cf       = maybe emptyCF id (lookup l (cfs st)),
@@ -358,9 +359,11 @@ stateGrammarOfLang st l = StGr {
   loptions = errVal noOptions $ lookupOptionsCan can
   }
  where
+   st = purgeShellState $ st0 {concrete = Just l}
    allCan = canModules st
-   can = M.partOfGrammar allCan 
-           (l, maybe M.emptyModInfo id (lookup l (M.modules allCan)))
+   can = allCan
+----   can = M.partOfGrammar allCan 
+----           (l, maybe M.emptyModInfo id (lookup l (M.modules allCan)))
 
 grammarOfLang :: ShellState -> Language -> CanonGrammar
 cfOfLang      :: ShellState -> Language -> CF