cleand up Structural

4 files changed, 42 insertions, 19 deletions

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