Introduced output of stripped format gfcm.

13 files changed, 92 insertions, 17 deletions

diff --git a/src/GF/API.hs b/src/GF/API.hs
index 29474585f..ab630d7a6 100644
--- a/src/GF/API.hs
+++ b/src/GF/API.hs
@@ -35,6 +35,7 @@ import qualified Compute as Co
 import qualified Ident as I
 import qualified GrammarToCanon as GC
 import qualified CanonToGrammar as CG
+import qualified MkGFC as MC
 
 import Editing
 
@@ -113,6 +114,9 @@ transformGrammarFile opts file = do
   return $ optPrintSyntax opts sy
 -}
 
+prIdent :: Ident -> String
+prIdent = prt
+
 -- then stg for customizable and internal use
 
 {- -----
@@ -257,6 +261,9 @@ optPrintGrammar opts = customOrDefault opts grammarPrinter customGrammarPrinter
 optPrintSyntax :: Options -> GF.Grammar -> String
 optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter
 
+prCanonGrammar :: CanonGrammar -> String
+prCanonGrammar = MC.prCanon
+
 {- ----
 optPrintTree :: Options -> GFGrammar -> Tree -> String
 optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter
diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs
index 9732c6ea8..483afbd86 100644
--- a/src/GF/API/IOGrammar.hs
+++ b/src/GF/API/IOGrammar.hs
@@ -1,6 +1,5 @@
 module IOGrammar where
 
-import Option
 import Abstract
 import qualified GFC
 import PGrammar
@@ -8,6 +7,8 @@ import TypeCheck
 import Compile
 import ShellState
 
+import Modules
+import Option
 import Operations
 import UseIO
 import Arch
@@ -35,6 +36,9 @@ string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt
 ---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList
 
 shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
+shellStateFromFiles opts st file | fileSuffix file == "gfcm" = do
+  (_,_,cgr) <- compileOne opts (compileEnvShSt st []) file
+  ioeErr $ updateShellState opts st (cgr,(emptyMGrammar,[]))  
 shellStateFromFiles opts st file = do
   let osb = if oElem showOld opts 
                then addOptions (options [beVerbose]) opts -- for old, no emit
diff --git a/src/GF/Canon/GFC.cf b/src/GF/Canon/GFC.cf
index 1816a77ad..4289b4c24 100644
--- a/src/GF/Canon/GFC.cf
+++ b/src/GF/Canon/GFC.cf
@@ -8,9 +8,9 @@ Gr. Canon ::= [Module] ;
 
 Mod. Module ::= ModType "=" Extend Open "{" [Flag] [Def] "}" ;
 
-MTAbs. ModType ::= "abstract" Ident ; 
-MTCnc. ModType ::= "concrete" Ident "of" Ident ;
-MTRes. ModType ::= "resource" Ident ;
+MTAbs.   ModType ::= "abstract" Ident ; 
+MTCnc.   ModType ::= "concrete" Ident "of" Ident ;
+MTRes.   ModType ::= "resource" Ident ;
 MTTrans. ModType ::= "transfer" Ident ":" Ident "->" Ident ;
 
 separator Module "" ;
@@ -18,8 +18,8 @@ separator Module "" ;
 Ext.   Extend ::= Ident "**" ;
 NoExt. Extend ::= ;
 
-NoOpens. Open ::= ;
 Opens.   Open ::= "open" [Ident] "in" ;
+NoOpens. Open ::= ;
 
 
 -- judgements
@@ -30,15 +30,15 @@ AbsDCat.   Def ::= "cat" Ident "[" [Decl] "]" "=" [CIdent] ;
 AbsDFun.   Def ::= "fun" Ident ":" Exp "=" Exp ;
 AbsDTrans. Def ::= "transfer" Ident "=" Exp ;
 
-ResDPar.  Def ::= "param"  Ident "=" [ParDef] ;
-ResDOper. Def ::= "oper"   Ident ":" CType "=" Term ;
+ResDPar.   Def ::= "param"  Ident "=" [ParDef] ;
+ResDOper.  Def ::= "oper"   Ident ":" CType "=" Term ;
 
-CncDCat.  Def ::= "lincat" Ident "=" CType "=" Term ";" Term  ; 
-CncDFun.  Def ::= "lin"    Ident ":" CIdent "=" "\\" [ArgVar] "->" Term ";" Term ;
+CncDCat.   Def ::= "lincat" Ident "=" CType "=" Term ";" Term  ; 
+CncDFun.   Def ::= "lin"    Ident ":" CIdent "=" "\\" [ArgVar] "->" Term ";" Term ;
 
-AnyDInd.  Def ::= Ident Status "in" Ident ;
+AnyDInd.   Def ::= Ident Status "in" Ident ;
 
-ParD.     ParDef ::= Ident [CType] ;
+ParD. ParDef ::= Ident [CType] ;
 
 -- the canonicity of an indirected constant
 
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
index 9346fce00..c83d628c7 100644
--- a/src/GF/Compile/Compile.hs
+++ b/src/GF/Compile/Compile.hs
@@ -125,6 +125,9 @@ extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) =
 
 extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm)
 
+extendCompileEnvCanon (k,s,c) cgr = 
+  return (k,s, MGrammar (modules cgr ++ modules c))
+
 compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
 compileOne opts env file = do
 
@@ -134,7 +137,12 @@ compileOne opts env file = do
   let name = fileBody file
 
   case gf of
-    -- for canonical gf, just read the file and update environment
+    -- for multilingual canonical gf, just read the file and update environment
+    "gfcm" -> do
+       cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
+       extendCompileEnvCanon env cgr
+
+    -- for canonical gf, read the file and update environment, also source env
     "gfc" -> do
        cm <- putp ("+ reading" +++ file) $ getCanonModule file
        sm <- ioeErr $ CG.canon2sourceModule cm
@@ -180,6 +188,12 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
   let putp = putPointE opts
       mos  = modules gr
 
+  if (oElem showOld opts && oElem emitCode opts) 
+    then do
+      let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo]))
+      ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
+    else return ()
+
   mo1   <- ioeErr $ rebuildModule mos mo
 
   mo1b  <- ioeErr $ extendModule mos mo1
diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs
index 2f5f916d6..c4784e243 100644
--- a/src/GF/Compile/ModDeps.hs
+++ b/src/GF/Compile/ModDeps.hs
@@ -11,6 +11,7 @@ import Modules
 import Operations
 
 import Monad
+import List
 
 -- AR 13/5/2003
 
@@ -106,6 +107,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.
+-- its argument is typically a concrete module name
+
+requiredCanModules :: (Eq i, Show i) => MGrammar i f a -> i -> [i]
+requiredCanModules gr = nub . iterFix (concatMap more) . singleton where
+  more i = errVal [] $ do
+    m <- lookupModMod gr i
+    return $ maybe [] return (extends m) ++ map openedModule (opens m)
+
+
+
 {-
 -- to test
 exampleDeps = [
@@ -117,3 +129,4 @@ exampleDeps = [
 ii s = IdentM (IC s) MTInterface
 ir s = IdentM (IC s) MTResource
 -}
+
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index 27d88f6fb..d0232b97e 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/src/GF/Compile/ShellState.hs
@@ -8,6 +8,7 @@ import MMacros
 
 import Look
 import LookAbs
+import ModDeps
 import qualified Modules as M
 import qualified Grammar as G
 import qualified PrGrammar as P
@@ -19,6 +20,8 @@ import Option
 import Ident
 import Arch (ModTime)
 
+import List (nub,nubBy)
+
 -- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
 
 -- multilingual state with grammars and options
@@ -169,6 +172,26 @@ filterAbstracts abstr cgr = M.MGrammar [m | m <- ms, needed m] where
     Just _ -> a : []
     _ -> []
 
+
+purgeShellState :: ShellState -> ShellState
+purgeShellState sh = ShSt {
+  abstract   = abstract sh,
+  concrete   = concrete sh,
+  concretes  = [(a,i) | (a,i) <- concretes sh, elem i needed],
+  canModules = M.MGrammar $ purge $ M.modules $ canModules sh,
+  srcModules = M.emptyMGrammar,
+  cfs        = cfs sh,
+  morphos    = morphos sh,
+  gloptions  = gloptions sh,
+  readFiles  = [],
+  absCats    = absCats sh,
+  statistics = statistics sh
+  }
+ where
+   needed = nub $ concatMap (requiredCanModules (canModules sh)) acncs
+   purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
+   acncs = maybe [] singleton (abstract sh) ++ map snd (concretes sh)
+
 -- form just one state grammar, if unique, from a canonical grammar
 
 grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar 
diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
index e400bce4e..6c557b479 100644
--- a/src/GF/Grammar/Compute.hs
+++ b/src/GF/Grammar/Compute.hs
@@ -25,7 +25,7 @@ computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t
 computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term
 computeTerm gr = comp where
 
-   comp g t = --- errIn ("subterm" +++ prt t) $ --- for debugging 
+   comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
               case t of
 
      Q (IC "Predef") _ -> return t
@@ -59,6 +59,7 @@ computeTerm gr = comp where
        a' <- comp g a
        case (f',a') of
          (Abs x b,_) -> comp (ext x a' g) b
+         (QC _ _,_)  -> returnC $ App f' a'
          (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . FV
          (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . FV
 
@@ -172,8 +173,10 @@ computeTerm gr = comp where
          _ -> return $ ExtR r' s'
 
      -- case-expand tables
+     -- if already expanded, don't expand again
      T i@(TComp _) cs -> do
-       cs' <- mapPairsM (comp g) cs
+       -- if there are no variables, don't even go inside
+       cs' <- if (null g) then return cs else mapPairsM (comp g) cs
        return $ T i cs'
 
      T i cs -> do
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 2edb183a1..291ea7521 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -175,6 +175,9 @@ appc = appCons . zIdent
 mkLet :: [LocalDef] -> Term -> Term
 mkLet defs t = foldr Let t defs
 
+mkLetUntyped :: Context -> Term -> Term
+mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (x,t) <- defs]
+
 isVariable (Vr _ ) = True
 isVariable _ = False
 
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index ac2f46b7e..a46127f16 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -139,6 +139,7 @@ latexLin    = showLatex
 tableLin    = iOpt "table"
 defaultLinOpts = [firstLin]
 useUTF8     = iOpt "utf8"
+showLang    = iOpt "lang"
 
 -- other
 beVerbose    = iOpt "v"
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 2fd686601..b0647b954 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -41,6 +41,7 @@ data Command =
    CImport FilePath
  | CRemoveLanguage Language
  | CEmptyState
+ | CStripState
  | CTransformGrammar FilePath
  | CConvertLatex FilePath
 
@@ -143,6 +144,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
     st1 <- shellStateFromFiles opts st file
     ioeIO $ changeState (const st1) sa --- \ ((_,h),a) -> ((st,h), a))
   CEmptyState         -> changeState reinitShellState sa
+  CStripState         -> changeState purgeShellState sa
 
 {-
   CRemoveLanguage lan -> changeState (removeLanguage lan) sa
@@ -209,7 +211,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
   CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa
   CPrintLanguages     -> justOutput 
                          (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa
-----  CPrintMultiGrammar  -> returnArg (AString (prMultiGrammar opts st)) sa
+  CPrintMultiGrammar  -> returnArg (AString (prCanonGrammar (canModules st))) sa
 ----  CPrintGramlet       -> returnArg (AString (Gr.prGramlet st)) sa
 ----  CPrintCanonXML      -> returnArg (AString (Canon.prCanonXML st False)) sa
 ----  CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa
diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
index f28218f27..666b5b681 100644
--- a/src/GF/Shell/PShell.hs
+++ b/src/GF/Shell/PShell.hs
@@ -51,6 +51,7 @@ pCommand ws = case ws of
   "i"  : f : [] -> aUnit   (CImport f)
   "rl" : l : [] -> aUnit   (CRemoveLanguage (language l))
   "e"  : []     -> aUnit   CEmptyState
+  "s"  : []     -> aUnit   CStripState
   "tg" : f : [] -> aUnit   (CTransformGrammar f)
   "cl" : f : [] -> aUnit   (CConvertLatex f)
 
diff --git a/src/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs
index 1b8a647df..0134b3530 100644
--- a/src/GF/Shell/SubShell.hs
+++ b/src/GF/Shell/SubShell.hs
@@ -26,7 +26,11 @@ translateSession :: Options -> ShellState -> IO ()
 translateSession opts st = do
   let grs   = allStateGrammars st
       cat   = firstCatOpts opts (firstStateGrammar st)
-      trans = unlines . translateBetweenAll grs cat
+      trans s = unlines $
+                if oElem showLang opts then 
+                  [l +++ ":" +++ s | (l,s) <- zip (map (prIdent . cncId) grs) 
+                                                  (translateBetweenAll grs cat s)]
+                  else translateBetweenAll grs cat s
   translateLoop opts trans
 
 translateLoop opts trans = do
diff --git a/src/Today.hs b/src/Today.hs
index 3647e0a63..1490e4866 100644
--- a/src/Today.hs
+++ b/src/Today.hs
@@ -1 +1 @@
-module Today where today = "Thu Dec  4 13:52:32 CET 2003"
+module Today where today = "Tue Dec  9 18:22:33 CET 2003"