From a1e8229910bbd01135d0e71c459872f87785a291 Mon Sep 17 00:00:00 2001
From: aarne <unknown>
Date: Sat, 5 Feb 2005 20:52:31 +0000
Subject: [PATCH] cleand up Structural

---
 src/GF.hs                        | 10 ++++----
 src/GF/Canon/CMacros.hs          |  3 ++-
 src/GF/Canon/CanonToGrammar.hs   | 10 ++++----
 src/GF/Compile/Compile.hs        |  4 ++--
 src/GF/Compile/GrammarToCanon.hs | 14 +++++++++--
 src/GF/Compile/MkResource.hs     |  2 +-
 src/GF/Compile/Optimize.hs       | 41 +++++++++++++++++++++-----------
 src/GF/Grammar/Compute.hs        |  5 +++-
 src/GF/Grammar/Grammar.hs        |  4 +++-
 src/GF/Grammar/Macros.hs         |  9 ++++++-
 src/GF/Shell.hs                  |  2 +-
 src/GF/Source/GrammarToSource.hs |  6 +++--
 src/GF/UseGrammar/Custom.hs      |  2 +-
 src/GF/UseGrammar/Morphology.hs  |  2 +-
 src/HelpFile                     |  8 +++----
 src/HelpFile.hs                  |  9 ++++---
 src/tools/MkHelpFile.hs          |  1 +
 17 files changed, 84 insertions(+), 48 deletions(-)

diff --git a/src/GF.hs b/src/GF.hs
index 80cf858c0..178e32b08 100644
--- a/src/GF.hs
+++ b/src/GF.hs
@@ -5,11 +5,11 @@
 -- Stability   : (stability)
 -- Portability : (portability)
 --
--- > CVS $Date: 2005/02/04 10:10:28 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.19 $
+-- > CVS $Date: 2005/02/05 21:52:31 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.20 $
 --
--- (Description of the module)
+-- The Main module of GF program.
 -----------------------------------------------------------------------------
 
 module Main (main) where
@@ -89,7 +89,7 @@ welcomeMsg =
   "Welcome to " ++ authorMsg ++++ welcomeArch ++ "\n\nType 'h' for help."
 
 authorMsg = unlines [
- "Grammatical Framework, Version 2.1.1b",
+ "Grammatical Framework, Version 2.1.2b",
  "Compiled " ++ today,
  "Copyright (c)", 
  "Björn Bringert, Markus Forsberg, Thomas Hallgren, Harald Hammarström,",
diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs
index d2c128454..8c655179a 100644
--- a/src/GF/Canon/CMacros.hs
+++ b/src/GF/Canon/CMacros.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Macros for building and analysing terms in GFC concrete syntax.
 -----------------------------------------------------------------------------
 
 module CMacros where
@@ -226,6 +226,7 @@ wordsInTerm trm = filter (not . null) $ case trm of
    S c _   -> wo c
    R rs    -> concat [wo t | Ass _ t <- rs]
    T _ cs  -> concat [wo t | Cas _ t <- cs]
+   V _ cs  -> concat [wo t | t <- cs]
    C s t   -> wo s ++ wo t
    FV ts   -> concatMap wo ts
    K (KP ss vs) -> ss ++ concat [s | Var s _ <- vs]
diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs
index cd4863442..16c2ae1f0 100644
--- a/src/GF/Canon/CanonToGrammar.hs
+++ b/src/GF/Canon/CanonToGrammar.hs
@@ -143,13 +143,13 @@ redCTerm x = case x of
   P term label  -> liftM2 G.P (redCTerm term) (return $ redLabel label)
   T ctype cases  -> do
     ctype' <- redCType ctype
-    let (ps,ts) = unzip [(p,t) | Cas ps t <- cases, p <- ps] --- destroys sharing
-    ps' <- mapM redPatt ps
-    ts' <- mapM redCTerm ts                   --- duplicates work for shared rhss
+    let (ps,ts) = unzip [(ps,t) | Cas ps t <- cases]
+    ps' <- mapM (mapM redPatt) ps
+    ts' <- mapM redCTerm ts
     let tinfo = case ps' of
-                  [G.PV _] -> G.TTyped ctype'
+                  [[G.PV _]] -> G.TTyped ctype'
                   _ -> G.TComp ctype'
-    return $ G.T tinfo $ zip ps' ts'
+    return $ G.TSh tinfo $ zip ps' ts'
   V ctype ts  -> do
     ctype' <- redCType ctype
     ts' <- mapM redCTerm ts
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
index bfd8f64f2..c1e006168 100644
--- a/src/GF/Compile/Compile.hs
+++ b/src/GF/Compile/Compile.hs
@@ -262,10 +262,10 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
 
       (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
 
-      mo4:_ <- 
+      mo4 <- 
 ----        case snd mo1b of
 ----          ModMod n | isModCnc n -> 
-        putp "  optimizing " $ ioeErr $ evalModule mos mo3r
+        putp "  optimizing " $ ioeErr $ optimizeModule opts mos mo3r
 ----        _ -> return [mo3r]
       return (k',mo4)
  where
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index 5ec5c8091..c090f1622 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Code generator from optimized GF source code to GFC.
 -----------------------------------------------------------------------------
 
 module GrammarToCanon where
@@ -187,7 +187,9 @@ redCType t = case t of
 
 redCTerm :: Term -> Err G.Term
 redCTerm t = case t of
-  Vr x -> liftM G.Arg $ redArgvar x
+  Vr x -> checkAgain 
+            (liftM G.Arg $ redArgvar x) 
+            (liftM G.LI  $ redIdent x) --- for parametrize optimization
   App _ _ -> do  -- only constructor applications can remain
     (_,c,xx) <- termForm t
     xx' <- mapM redCTerm xx
@@ -212,6 +214,13 @@ redCTerm t = case t of
     ps' <- mapM redPatt ps
     ts' <- mapM redCTerm ts
     return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
+  TSh i cs -> do
+    ty  <- getTableType i
+    ty' <- redCType ty
+    let (pss,ts) = unzip cs
+    pss' <- mapM (mapM redPatt) pss
+    ts' <- mapM redCTerm ts
+    return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts'
   V ty ts     -> do
     ty' <- redCType ty
     ts' <- mapM redCTerm ts
@@ -247,6 +256,7 @@ redPatt p = case p of
     return $ G.PR $  map (uncurry G.PAss) $ zip ls' ts
   PT _ q -> redPatt q
   PInt i -> return $ G.PI (toInteger i)
+  PV x -> liftM G.PV $ redIdent x --- for parametrize optimization
   _ -> prtBad "cannot reduce pattern" p
 
 redLabel :: Label -> G.Label
diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs
index cd374ff41..1c0bdb21c 100644
--- a/src/GF/Compile/MkResource.hs
+++ b/src/GF/Compile/MkResource.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
 -----------------------------------------------------------------------------
 
 module MkResource where
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index ef98e7dab..47405f0b4 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Top-level partial evaluation for GF source modules.
 -----------------------------------------------------------------------------
 
 module Optimize where
@@ -22,25 +22,38 @@ import Macros
 import Lookup
 import Refresh
 import Compute
+import BackOpt
 import CheckGrammar
 import Update
 
 import Operations
 import CheckM
+import Option
 
 import Monad
 import List
 
--- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003
-{-
-evalGrammar :: SourceGrammar -> Err SourceGrammar
-evalGrammar gr = do
-  gr2 <- refreshGrammar gr
-  mos <- foldM evalModule [] $ modules gr2
-  return $ MGrammar $ reverse mos 
--}
+-- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003 -- 5/2/2005
+-- only do this for resource: concrete is optimized in gfc form
+
+optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> 
+                  Err (Ident,SourceModInfo)
+optimizeModule opts ms mo@(_,mi) = case mi of
+  ModMod m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do
+      mo1 <- evalModule ms mo
+      let oopts = addOptions opts (iOpts (flagsModule mo1))
+          optim = maybe "none" id $ getOptVal oopts useOptimizer
+      return $ case optim of
+        "parametrize" -> shareModule paramOpt mo1  -- parametrization and sharing
+        "values"      -> shareModule valOpt mo1    -- tables as courses-of-values
+        "share"       -> shareModule shareOpt mo1  -- sharing of branches
+        "all"         -> shareModule allOpt mo1    -- first parametrize then values
+        "none"        -> mo1                       -- no optimization
+        _             -> mo1                       -- none; default for src
+  _ -> evalModule ms mo
+
 evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> 
-               Err [(Ident,SourceModInfo)]
+               Err (Ident,SourceModInfo)
 evalModule ms mo@(name,mod) = case mod of
 
   ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
@@ -48,13 +61,13 @@ evalModule ms mo@(name,mod) = case mod of
       let deps = allOperDependencies name js
       ids <- topoSortOpers deps
       MGrammar (mod' : _) <- foldM evalOp gr ids
-      return $ mod' : ms
+      return $ mod'
     MTConcrete a -> do
       js' <- mapMTree (evalCncInfo gr0 name a) js
-      return $ (name, ModMod (Module mt st fs me ops js')) : ms
+      return $ (name, ModMod (Module mt st fs me ops js'))
 
-    _ -> return $ (name,mod):ms
-  _ -> return $ (name,mod):ms
+    _ -> return $ (name,mod)
+  _ -> return $ (name,mod)
  where
    gr0 = MGrammar $ ms
    gr  = MGrammar $ (name,mod) : ms
diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
index 71bed6d49..2ddce3a6c 100644
--- a/src/GF/Grammar/Compute.hs
+++ b/src/GF/Grammar/Compute.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Computation of source terms. Used in compilation and in 'cc' command.
 -----------------------------------------------------------------------------
 
 module Compute where
@@ -218,6 +218,9 @@ computeTerm gr = comp where
        cs' <- if (null g) then return cs else mapPairsM (comp g) cs
        return $ T i cs'
 
+     --- this means some extra work; should implement TSh directly
+     TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
+
      T i cs -> do
        pty0 <- getTableType i
        ptyp <- comp g pty0
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index d5d59aec3..8ab2356d2 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- GF source abstract syntax used internally in compilation.
 -----------------------------------------------------------------------------
 
 module Grammar where
@@ -91,6 +91,7 @@ data Term =
  
  | Table Term Term      -- table type:  P => A
  | T TInfo [Case]       -- table:       table {p => c ; ...}
+ | TSh TInfo [Cases]    -- table with discjunctive patters (only back end opt)
  | V Type [Term]        -- table given as course of values: table T [c1 ; ... ; cn]
  | S Term Term          -- selection:   t ! p
 
@@ -149,6 +150,7 @@ type Equation = ([Patt],Term)
 type Labelling = (Label, Term) 
 type Assign = (Label, (Maybe Type, Term)) 
 type Case = (Patt, Term) 
+type Cases = ([Patt], Term) 
 type LocalDef = (Ident, (Maybe Type, Term))
 
 type Param = (Ident, Context) 
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 8c1ac36d7..cfc71b1a5 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Macros for constructing and analysing source code terms.
 -----------------------------------------------------------------------------
 
 module Macros where
@@ -603,6 +603,11 @@ composOp co trm =
         i'  <- changeTableType co i
         return (T i' cc')
 
+   TSh i cc -> 
+     do cc' <- mapPairListM (co . snd) cc
+        i'  <- changeTableType co i
+        return (TSh i' cc')
+
    V ty vs ->
      do ty' <- co ty
         vs' <- mapM co vs
@@ -661,6 +666,8 @@ collectOp co trm = case trm of
   RecType r  -> concatMap (co . snd) r 
   P t i      -> co t
   T _ cc     -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
+  TSh _ cc   -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
+  V _ cc     -> concatMap co         cc --- nor from type annot
   Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
   C s1 s2    -> co s1 ++ co s2 
   Glue s1 s2 -> co s1 ++ co s2 
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index de33de3f0..c98adfb66 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- GF shell command interpreter.
 -----------------------------------------------------------------------------
 
 module Shell where
diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
index 346af7101..24826c7f7 100644
--- a/src/GF/Source/GrammarToSource.hs
+++ b/src/GF/Source/GrammarToSource.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- From internal source syntax to BNFC-generated (used for printing).
 -----------------------------------------------------------------------------
 
 module GrammarToSource where
@@ -139,6 +139,7 @@ trt trm = case trm of
     P t l -> P.EProj (trt t) (trLabel l)
     Q t l -> P.EQCons (tri t) (tri l)
     QC t l -> P.EQConstr (tri t) (tri l)
+    TSh (TComp ty) cc -> P.ETTable (trt ty) (map trCases cc)
     T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
     T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
     T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
@@ -192,7 +193,8 @@ trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t')
 
 trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
 
-trCase (patt,trm) = P.Case [P.AltP (trp patt)] (trt trm)
+trCase  (patt, trm) = P.Case [P.AltP (trp patt)] (trt trm)
+trCases (patts,trm) = P.Case (map (P.AltP . trp) patts) (trt trm)
 
 trDecl (x,ty) = P.DDDec [trb x] (trt ty)
 
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index fd9971c73..4ec37d1ae 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- A database for customizable GF shell commands. 
 -----------------------------------------------------------------------------
 
 module Custom where
diff --git a/src/GF/UseGrammar/Morphology.hs b/src/GF/UseGrammar/Morphology.hs
index f23401068..418bce001 100644
--- a/src/GF/UseGrammar/Morphology.hs
+++ b/src/GF/UseGrammar/Morphology.hs
@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Morphological analyser constructed from a GF grammar.
 -----------------------------------------------------------------------------
 
 module Morphology where
diff --git a/src/HelpFile b/src/HelpFile
index 5581039f2..c9e015810 100644
--- a/src/HelpFile
+++ b/src/HelpFile
@@ -428,17 +428,15 @@ q, quit: q
        The default is unlimited.
 
 -optimize, optimization on generated code.
-       The default is share.
+       The default is share for concrete, none for resource modules.
     -optimize=share        share common branches in tables
     -optimize=parametrize  first try parametrize then do share with the rest
     -optimize=values       represent tables as courses-of-values
     -optimize=all          first try parametrize then do values with the rest
     -optimize=none         no optimization
 
-
--parser, Context-free    parsing algorithm. The default is chart.
-    -parser=earley       Earley algorithm
-    -parser=chart        bottom-up chart parser
+-parser, Context-free    parsing algorithm. Under construction.
+       The default is a chart parser via context-free approximation.
 
 -printer, format in which the grammar is printed. The default is gfc.
     -printer=gfc            GFC grammar
diff --git a/src/HelpFile.hs b/src/HelpFile.hs
index 0b78947bb..c2bed6b15 100644
--- a/src/HelpFile.hs
+++ b/src/HelpFile.hs
@@ -10,6 +10,7 @@
 -- > CVS $Revision $
 --
 -- Help on shell commands. Generated from HelpFile by 'make help'.
+-- PLEASE DON'T EDIT THIS FILE.
 -----------------------------------------------------------------------------
 
 
@@ -456,17 +457,15 @@ txtHelpFile =
   "\n       The default is unlimited." ++
   "\n" ++
   "\n-optimize, optimization on generated code." ++
-  "\n       The default is share." ++
+  "\n       The default is share for concrete, none for resource modules." ++
   "\n    -optimize=share        share common branches in tables" ++
   "\n    -optimize=parametrize  first try parametrize then do share with the rest" ++
   "\n    -optimize=values       represent tables as courses-of-values" ++
   "\n    -optimize=all          first try parametrize then do values with the rest" ++
   "\n    -optimize=none         no optimization" ++
   "\n" ++
-  "\n" ++
-  "\n-parser, Context-free    parsing algorithm. The default is chart." ++
-  "\n    -parser=earley       Earley algorithm" ++
-  "\n    -parser=chart        bottom-up chart parser" ++
+  "\n-parser, Context-free    parsing algorithm. Under construction." ++
+  "\n       The default is a chart parser via context-free approximation." ++
   "\n" ++
   "\n-printer, format in which the grammar is printed. The default is gfc." ++
   "\n    -printer=gfc            GFC grammar" ++
diff --git a/src/tools/MkHelpFile.hs b/src/tools/MkHelpFile.hs
index 6f7fe0184..fc0db2e00 100644
--- a/src/tools/MkHelpFile.hs
+++ b/src/tools/MkHelpFile.hs
@@ -54,6 +54,7 @@ helpHeader = unlines [
   "-- > CVS $Revision $",
   "--",
   "-- Help on shell commands. Generated from HelpFile by 'make help'.",
+  "-- PLEASE DON'T EDIT THIS FILE.",
   "-----------------------------------------------------------------------------",
   "",
   ""