-val optimization

doc/val-optimization.txt

@@ -0,0 +1,183 @@
+Idea: in GFC, represent tables as just lists values, without showing
+the parameters.
+
+Concrete syntax: 
+
+  table T [t1 ; ... ; tn]
+
+where t1,...,tn are terms. This is treated as equivalent to
+
+  table {p1 => t1 ; ... ; pn => tn}
+
+where p1,...,pn is the canonical listing of patterns of type T.
+
+Advantage: reduce the size of GFC files.
+
+Disadvantages: you don't get the sharing optimization, e.g.
+table {A|B => v} instead of table T [v ; v] 
+Moreover, it is slower to select from the table, because
+one first has to look up the position index of the argument.
+
+Usage: when compiling a module, use the -val option:
+
+  i -val -src Foo.gf
+
+Summary of results, testing with lib/resource/french/TestVerbesFre.gf:
+
+                              without -val    with -val    ratio
+  compilation time                   129 s         84 s     65 %
+  time to read back gfcm             109 s         32 s     29 %
+  size of generated gfcm              28 M          9 M     32 %
+  memory use in compilation          376 M        251 M     67 %
+  memory use in reading gfcm        1120 M        524 M     47 %
+
+No significant loss in linearization (which needs selection).
+
+Conclusion: for the case at hand (which prompted the experiment
+at the first place), the gain is significant: compilation needs
+30 % less resources, and using the compiled grammar needs
+50-70 % less.
+
+More testing is desirable to find out if -val is always good.
+
+At the moment, reuse is not possible with gfc modules created
+with the -val flag (although it is supported by the GF syntax
+already).
+
+
+
+10/1/2004
+
+Test the generation of course-of-values tables
+
+---------------------
+Without:
+
+  i -src TestVerbesFre.gf
+  129160 msec
+
+  > gr -cat=V | l -table
+  650 msec
+
+gf +RTS -K10M -s
+8,469,778,952 bytes allocated in the heap
+2,779,891,252 bytes copied during GC
+133,108,856 bytes maximum residency (36 sample(s))
+
+      32295 collections in generation 0 ( 24,25s)
+         36 collections in generation 1 ( 24,68s)
+
+        376 Mb total memory in use
+
+  INIT  time    0,01s  (  0,04s elapsed)
+  MUT   time   80,21s  (499,76s elapsed)
+  GC    time   48,93s  ( 50,01s elapsed)
+  EXIT  time    0,00s  (  0,00s elapsed)
+  Total time  129,15s  (549,81s elapsed)
+
+  %GC time      37,9%  (9,1% elapsed)
+
+  Alloc rate    105,581,886 bytes per MUT second
+
+  Productivity  62,1% of total user, 14,6% of total elapsed
+
+
+wc french/*.gfc french/*.gfr
+      37     2533    44976 french/CategoriesFre.gfc
+       0        9       62 french/ConjugNancy.gfc
+       2       29      137 french/MorphoFre.gfc
+      29      966     7641 french/NumeralsFre.gfc
+     136   393891  4415193 french/RulesFre.gfc
+     151     4211    39290 french/StructuralFre.gfc
+     123      607     3259 french/SyntaxFre.gfc
+     285     4702    59892 french/TestResourceFre.gfc
+    6790    27179   184046 french/TestVerbesAbs.gfc
+    6781    28170   198376 french/TestVerbesFre.gfc
+      20      214     1245 french/TypesFre.gfc
+    6494    45458   254878 french/VerbesAbs.gfc
+    6494  1272600 23438292 french/VerbesFre.gfc
+    6449    45143   209154 french/Vs.gfc
+    6278    47836   426316 french/ConjugNancy.gfr
+   14465    72471   655006 french/MorphoFre.gfr
+  238250   798560  8973600 french/SyntaxFre.gfr
+     492     2557    21908 french/TypesFre.gfr
+  293276  2747136 38933271 total
+
+pm | wf test0.gfcm
+55660 msec
+
+wc test0.gfcm
+   28041  1784674 28669416 test0.gfcm
+
+> i test0.gfcm
++ reading test0.gfcm 103290 msec
+109450 msec
+
+1120 Mb total memory in use
+
+----------------------
+After:
+
+
+  i -src -val TestVerbesFre.gf
+  84650 msec
+
+  gr -cat=V | l -table
+  390 msec
+
+gf +RTS -K10M -s
+6,061,907,436 bytes allocated in the heap
+1,576,739,488 bytes copied during GC
+ 92,700,188 bytes maximum residency (32 sample(s))
+
+      23109 collections in generation 0 ( 13,98s)
+         32 collections in generation 1 ( 12,02s)
+
+        251 Mb total memory in use
+
+  INIT  time    0,01s  (  0,00s elapsed)
+  MUT   time   59,28s  (122,35s elapsed)
+  GC    time   26,00s  ( 26,91s elapsed)
+  EXIT  time    0,00s  (  0,00s elapsed)
+  Total time   85,29s  (149,26s elapsed)
+
+  %GC time      30,5%  (18,0% elapsed)
+
+  Alloc rate    102,241,650 bytes per MUT second
+
+  Productivity  69,5% of total user, 39,7% of total elapsed
+
+wc french/*.gfc french/*.gfr
+      37     3894    13600 french/CategoriesFre.gfc
+       0        9       62 french/ConjugNancy.gfc
+       2       29      137 french/MorphoFre.gfc
+      29      938     5726 french/NumeralsFre.gfc
+     136   354450  3097901 french/RulesFre.gfc
+     151     3738    22354 french/StructuralFre.gfc
+     123      607     3259 french/SyntaxFre.gfc
+     285     2437    18664 french/TestResourceFre.gfc
+    6790    27179   184046 french/TestVerbesAbs.gfc
+    6781    27694   191696 french/TestVerbesFre.gfc
+      20      214     1245 french/TypesFre.gfc
+    6494    45458   254878 french/VerbesAbs.gfc
+    6494   442149  5078881 french/VerbesFre.gfc
+    6449    45143   209154 french/Vs.gfc
+    6278    47836   426316 french/ConjugNancy.gfr
+   14465    72471   655006 french/MorphoFre.gfr
+  238250   798560  8973600 french/SyntaxFre.gfr
+     492     2557    21908 french/TypesFre.gfr
+  293276  1875363 19158433 total
+
+pm | wf test1.gfcm
+13030 msec
+
+wc test1.gfcm
+  28041  912901 8894578 test1.gfcm
+
+> i test1.gfcm
++ reading test1.gfcm 24220 msec
+32720 msec
+
+524 Mb total memory in use
+
+

grammars/database/DatabaseI.gf

@@ -1,6 +1,6 @@
 --# -path=.:../newresource/abstract:../prelude
 
-incomplete concrete DatabaseI of Database = open Prelude, Resource, Structural in {
+incomplete concrete DatabaseI of Database = open Prelude, Resource in {
 
 flags lexer=text ; unlexer=text ;
 

src/GF/CF/CanonToCF.hs

@@ -97,6 +97,9 @@ term2CFItems m t = errIn "forming cf items" $ case t of
    T _ cc -> do
      its  <- mapM t2c [t | Cas _ t <- cc]
      tryMkCFTerm (concat its)
+   V _ cc -> do
+     its  <- mapM t2c [t | t <- cc]
+     tryMkCFTerm (concat its)
 
    C t1 t2 -> do
      its1 <- t2c t1

src/GF/Canon/AbsGFC.hs

@@ -119,6 +119,7 @@ data Term =
  | R [Assign]
  | P Term Label
  | T CType [Case]
+ | V CType [Term]
  | S Term Term
  | C Term Term
  | FV [Term]

src/GF/Canon/CanonToGrammar.hs

@@ -136,6 +136,10 @@ redCTerm x = case x of
                   [G.PV _] -> G.TTyped ctype'
                   _ -> G.TComp ctype'
     return $ G.T tinfo $ zip ps' ts'
+  V ctype ts  -> do
+    ctype' <- redCType ctype
+    ts' <- mapM redCTerm ts
+    return $ G.V ctype' ts'
   S term0 term  -> liftM2 G.S (redCTerm term0) (redCTerm term)
   C term0 term  -> liftM2 G.C (redCTerm term0) (redCTerm term)
   FV terms  -> liftM G.FV $ mapM redCTerm terms

src/GF/Canon/GFC.cf

@@ -105,6 +105,7 @@ LI.   Term2 ::= "$" Ident ;  -- from pattern variables
 R.    Term2 ::= "{" [Assign] "}" ;
 P.    Term1 ::= Term2 "." Label ;
 T.    Term1 ::= "table" CType "{" [Case] "}" ;
+V.    Term1 ::= "table" CType "[" [Term2] "]" ;
 S.    Term1 ::= Term1 "!" Term2 ;
 C.    Term  ::= Term "++" Term1 ;
 FV.   Term1 ::= "variants" "{" [Term2] "}" ;  --- no separator!

src/GF/Canon/LexGFC.x

@@ -4,7 +4,6 @@
 module LexGFC where
 
 import ErrM
-import SharedString
 }
 
 
@@ -21,28 +20,25 @@ $u = [\0-\255]          -- universal: any character
 :-
 
 $white+ ;
-@rsyms { tok (\p s -> PT p (TS $ share s)) }
+@rsyms { tok (\p s -> PT p (TS s)) }
 
-$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+$l $i*   { tok (\p s -> PT p (eitherResIdent TV s)) }
-\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail s)) }
 
-$d+      { tok (\p s -> PT p (TI $ share s))    }
+$d+      { tok (\p s -> PT p (TI s))    }
 
 
 {
 
 tok f p s = f p s
 
-share :: String -> String
-share = shareString
-
 data Tok =
-   TS !String     -- reserved words
+   TS String     -- reserved words
- | TL !String     -- string literals
+ | TL String     -- string literals
- | TI !String     -- integer literals
+ | TI String     -- integer literals
- | TV !String     -- identifiers
+ | TV String     -- identifiers
- | TD !String     -- double precision float literals
+ | TD String     -- double precision float literals
- | TC !String     -- character literals
+ | TC String     -- character literals
 
  deriving (Eq,Show,Ord)
 
@@ -67,18 +63,20 @@ prToken t = case t of
 
   _ -> show t
 
-data BTree = N | B String Tok BTree BTree deriving (Show)
-
 eitherResIdent :: (String -> Tok) -> String -> Tok
-eitherResIdent tv s = treeFind resWords
+eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
-  where
+  isResWord s = isInTree s $
-  treeFind N = tv s
+    B "lin" (B "concrete" (B "Type" (B "Str" (B "Ints" N N) N) (B "cat" (B "abstract" N N) N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" (B "grammar" N N) N))) (B "pre" (B "open" (B "of" (B "lincat" N N) N) (B "param" (B "oper" N N) N)) (B "transfer" (B "table" (B "resource" N N) N) (B "variants" N N)))
-  treeFind (B a t left right) | s < a  = treeFind left
-                              | s > a  = treeFind right
-                              | s == a = t
 
-resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N)))
+data BTree = N | B String BTree BTree deriving (Show)
-   where b s = B s (TS s)
+
+isInTree :: String -> BTree -> Bool
+isInTree x tree = case tree of
+  N -> False
+  B a left right
+   | x < a  -> isInTree x left
+   | x > a  -> isInTree x right
+   | x == a -> True
 
 unescapeInitTail :: String -> String
 unescapeInitTail = unesc . tail where

src/GF/Canon/Look.hs

@@ -151,6 +151,12 @@ ccompute cnc = comp []
     T ty rs -> liftM (T ty . map (uncurry Cas)) $ 
                   mapPairsM compt [(l,r) | Cas l r <- rs]
 
+    V ptyp ts -> do
+      vs0 <- allParamValues cnc ptyp
+      vs  <- mapM term2patt vs0
+      let cc = [Cas [p] u | (p,u) <- zip vs ts]
+      compt $ T ptyp cc
+
     Con c xs -> liftM (Con c) $ mapM compt xs
 
     K (KS []) -> return E --- should not be needed

src/GF/Canon/PrintGFC.hs

@@ -258,6 +258,7 @@ instance Print Term where
    R assigns -> prPrec i 2 (concatD [doc (showString "{") , prt 0 assigns , doc (showString "}")])
    P term label -> prPrec i 1 (concatD [prt 2 term , doc (showString ".") , prt 0 label])
    T ctype cases -> prPrec i 1 (concatD [doc (showString "table") , prt 0 ctype , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   V ctype terms -> prPrec i 1 (concatD [doc (showString "table") , prt 0 ctype , doc (showString "[") , prt 2 terms , doc (showString "]")])
    S term0 term -> prPrec i 1 (concatD [prt 1 term0 , doc (showString "!") , prt 2 term])
    C term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "++") , prt 1 term])
    FV terms -> prPrec i 1 (concatD [doc (showString "variants") , doc (showString "{") , prt 2 terms , doc (showString "}")])

src/GF/Canon/Share.hs

@@ -1,4 +1,4 @@
-module Share (shareModule, OptSpec, basicOpt, fullOpt) where
+module Share (shareModule, OptSpec, basicOpt, fullOpt, valOpt) where
 
 import AbsGFC
 import Ident
@@ -13,8 +13,10 @@ import qualified Modules as M
 
 type OptSpec = [Integer] ---
 doOptFactor opt = elem 2 opt
+doOptValues opt = elem 3 opt
 basicOpt = []
 fullOpt = [2]
+valOpt = [3]
 
 shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo)
 shareModule opt (i,m) = case m of
@@ -30,6 +32,7 @@ shareInfo _ i = i
 shareOpt :: OptSpec -> Term -> Term
 shareOpt opt 
   | doOptFactor opt = share . factor 0
+  | doOptValues opt = values    
   | otherwise = share
 
 -- we need no counter to create new variable names, since variables are 
@@ -114,3 +117,7 @@ replace old new trm = case trm of
      R _ -> True
      _ -> False
 
+values :: Term -> Term
+values t = case t of
+  T ty cs  -> V ty [values t | Cas _ t <- cs] -- assumes proper order
+  _ -> C.composSafeOp values t

src/GF/Canon/SkelGFC.hs

@@ -146,6 +146,7 @@ transTerm x = case x of
   R assigns  -> failure x
   P term label  -> failure x
   T ctype cases  -> failure x
+  V ctype terms  -> failure x
   S term0 term  -> failure x
   C term0 term  -> failure x
   FV terms  -> failure x
@@ -158,6 +159,7 @@ transTokn :: Tokn -> Result
 transTokn x = case x of
   KS str  -> failure x
   KP strs variants  -> failure x
+  KM str  -> failure x
 
 
 transAssign :: Assign -> Result

src/GF/Canon/TestGFC.hs

@@ -18,22 +18,28 @@ type ParseFun a = [Token] -> Err a
 
 myLLexer = myLexer
 
-runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO ()
+type Verbosity = Int
-runFile p f = readFile f >>= run p
 
-run :: (Print a, Show a) => ParseFun a -> String -> IO ()
+putStrV :: Verbosity -> String -> IO ()
-run p s = case (p (myLLexer s)) of
+putStrV v s = if v > 1 then putStrLn s else return ()
-           Bad s    -> do  putStrLn "\nParse Failed...\n"
+
+runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+           Bad s    -> do  putStrLn "\nParse              Failed...\n"
+                           putStrV v "Tokens:"
+                           putStrV v $ show ts
                            putStrLn s
            Ok  tree -> do putStrLn "\nParse Successful!"
-                          putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
+                          putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
-                          putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
+                          putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
 
 
 main :: IO ()
 main = do args <- getArgs
           case args of
-            []  -> hGetContents stdin >>= run pCanon
+            [] -> hGetContents stdin >>= run 2 pCanon
-            [f] -> runFile pCanon f
+            "-s":fs -> mapM_ (runFile 0 pCanon) fs
-            _   -> do progName <- getProgName
+            fs -> mapM_ (runFile 2 pCanon) fs
-                      putStrLn $ progName ++ ": excess arguments."

src/GF/Compile/Compile.hs

@@ -252,9 +252,12 @@ generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
 generateModuleCode opts path minfo@(name,info) = do
   let pname = prefixPathName path (prt name)
   minfo0     <- ioeErr $ redModInfo minfo
-  minfo'     <- return $ if optim 
+  minfo'     <- return $ 
-                then shareModule fullOpt minfo0   -- parametrization and sharing
+    if optim 
-                else shareModule basicOpt minfo0  -- sharing only
+    then shareModule fullOpt minfo0   -- parametrization and sharing
+    else if values                    
+    then shareModule valOpt minfo0     -- tables as courses-of-values
+    else shareModule basicOpt minfo0  -- sharing only
 
   -- for resource, also emit gfr
   case info of
@@ -279,6 +282,7 @@ generateModuleCode opts path minfo@(name,info) = do
    nomulti = not $ oElem makeMulti opts
    emit  = oElem emitCode opts && not (oElem notEmitCode opts)
    optim = oElem optimizeCanon opts
+   values = oElem optimizeValues opts
 
 -- for old GF: sort into modules, write files, compile as usual
 

src/GF/Compile/GrammarToCanon.hs

@@ -198,6 +198,10 @@ 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'
+  V ty ts     -> do
+    ty' <- redCType ty
+    ts' <- mapM redCTerm ts
+    return $ G.V ty' ts'
   S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
   K s   -> return $ G.K (G.KS s)
   EInt i -> return $ G.EInt $ toInteger i

src/GF/Compile/Optimize.hs

@@ -188,6 +188,7 @@ evalPrintname gr c ppr lin =
      Abs _ b   -> oneBranch b
      R   (r:_) -> oneBranch $ snd $ snd r
      T _ (c:_) -> oneBranch $ snd c
+     V _ (c:_) -> oneBranch c
      FV  (t:_) -> oneBranch t
      C x y     -> C (oneBranch x) (oneBranch y)
      S x _     -> oneBranch x

src/GF/Grammar/Compute.hs

@@ -101,6 +101,17 @@ computeTerm gr = comp where
 
          FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . FV
 
+         V ptyp ts -> do
+           vs <- allParamValues gr ptyp
+           ps <- mapM term2patt vs
+           let cc = zip ps ts
+           case v' of
+             FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV
+             _ -> case matchPattern cc v' of
+               Ok (c,g') -> comp (g' ++ g) c
+               _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t 
+               _ -> return $ S t' v' -- if v' is not canonical
+
          T _ cc -> case v' of
 	   FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV
            _ -> case matchPattern cc v' of
@@ -204,7 +215,8 @@ computeTerm gr = comp where
            ts   <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
            ps   <- mapM term2patt vs
            let ps' = ps --- PT ptyp (head ps) : tail ps
-           return $ T (TComp ptyp) (zip ps' ts)
+           return $ --- V ptyp ts -- to save space, just course of values
+                    T (TComp ptyp) (zip ps' ts)
          _ -> do
            cs' <- mapM (compBranch g) cs
            return $ T i cs'  -- happens with variable types

src/GF/Grammar/Grammar.hs

@@ -77,6 +77,7 @@ data Term =
  
  | Table Term Term      -- table type:  P => A
  | T TInfo [Case]       -- table:       table {p => c ; ...}
+ | V Type [Term]        -- table given as course of values: table T [c1 ; ... ; cn]
  | S Term Term          -- selection:   t ! p
 
  | Let LocalDef Term    -- local definition: let {t : T = a} in b

src/GF/Grammar/Macros.hs

@@ -588,6 +588,12 @@ composOp co trm =
      do cc' <- mapPairListM (co . snd) cc
         i'  <- changeTableType co i
         return (T i' cc')
+
+   V ty vs ->
+     do ty' <- co ty
+        vs' <- mapM co vs
+        return (V ty' vs')
+
    Let (x,(mt,a)) b -> 
      do a'  <- co a
         mt' <- case mt of

src/GF/Infra/Option.hs

@@ -163,6 +163,7 @@ doTrace      = iOpt "tr"
 noCPU        = iOpt "nocpu"
 doCompute    = iOpt "c"
 optimizeCanon = iOpt "opt"
+optimizeValues = iOpt "val"
 stripQualif   = iOpt "strip"
 nostripQualif = iOpt "nostrip"
 showAll      = iOpt "all"

src/GF/Shell/ShellCommands.hs

@@ -134,7 +134,7 @@ testValidFlag st co f x = case f of
 
 optionsOfCommand :: Command -> ([String],[String])
 optionsOfCommand co = case co of
-  CImport _ -> both "old v s opt src retain nocf nocheckcirc cflexer noemit o"
+  CImport _ -> both "old v s opt val src retain nocf nocheckcirc cflexer noemit o"
                     "abs cnc res path"
   CRemoveLanguage _ -> none
   CEmptyState -> none

src/GF/Source/AbsGF.hs

@@ -167,6 +167,7 @@ data Exp =
  | EQCons Ident Ident
  | EApp Exp Exp
  | ETable [Case]
+ | EVTable Exp [Exp]
  | ETTable Exp [Case]
  | ECase Exp [Case]
  | EVariants [Exp]

src/GF/Source/GF.cf

@@ -160,6 +160,7 @@ EQCons.    Exp3 ::= "[" Ident "." Ident "]" ;  -- qualified constant
 EApp.      Exp2 ::= Exp2 Exp3 ;
 ETable.    Exp2 ::= "table" "{" [Case] "}" ;
 ETTable.   Exp2 ::= "table" Exp4 "{" [Case] "}" ;
+EVTable.   Exp2 ::= "table" Exp4 "[" [Exp] "]" ;
 ECase.     Exp2 ::= "case" Exp "of" "{" [Case] "}" ;
 EVariants. Exp2 ::= "variants" "{" [Exp] "}" ;
 EPre.      Exp2 ::= "pre" "{" Exp ";" [Altern] "}" ;

src/GF/Source/GrammarToSource.hs

@@ -129,6 +129,7 @@ trt trm = case trm of
     T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
     T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
     T _ cc -> P.ETable (map trCase cc)
+    V ty cc -> P.EVTable (trt ty) (map trt cc)
 
     Table x v -> P.ETType (trt x) (trt v)
     S f x -> P.ESelect  (trt f) (trt x)

src/GF/Source/LexGF.x

@@ -4,7 +4,6 @@
 module LexGF where
 
 import ErrM
-import SharedString
 }
 
 
@@ -23,30 +22,27 @@ $u = [\0-\255]          -- universal: any character
 "{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; 
 
 $white+ ;
-@rsyms { tok (\p s -> PT p (TS $ share s)) }
+@rsyms { tok (\p s -> PT p (TS s)) }
-\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
+\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent T_LString s)) }
 
-$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+$l $i*   { tok (\p s -> PT p (eitherResIdent TV s)) }
-\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail s)) }
 
-$d+      { tok (\p s -> PT p (TI $ share s))    }
+$d+      { tok (\p s -> PT p (TI s))    }
 
 
 {
 
 tok f p s = f p s
 
-share :: String -> String
-share = shareString
-
 data Tok =
-   TS !String     -- reserved words
+   TS String     -- reserved words
- | TL !String     -- string literals
+ | TL String     -- string literals
- | TI !String     -- integer literals
+ | TI String     -- integer literals
- | TV !String     -- identifiers
+ | TV String     -- identifiers
- | TD !String     -- double precision float literals
+ | TD String     -- double precision float literals
- | TC !String     -- character literals
+ | TC String     -- character literals
- | T_LString !String
+ | T_LString String
 
  deriving (Eq,Show,Ord)
 
@@ -72,18 +68,20 @@ prToken t = case t of
 
   _ -> show t
 
-data BTree = N | B String Tok BTree BTree deriving (Show)
-
 eitherResIdent :: (String -> Tok) -> String -> Tok
-eitherResIdent tv s = treeFind resWords
+eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
-  where
+  isResWord s = isInTree s $
-  treeFind N = tv s
+    B "lincat" (B "def" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "data" (B "concrete" N N) N))) (B "include" (B "fun" (B "fn" (B "flags" N N) N) (B "in" (B "grammar" N N) N)) (B "interface" (B "instance" (B "incomplete" N N) N) (B "lin" (B "let" N N) N)))) (B "resource" (B "out" (B "of" (B "lintype" (B "lindef" N N) N) (B "oper" (B "open" N N) N)) (B "pattern" (B "param" (B "package" N N) N) (B "printname" (B "pre" N N) N))) (B "union" (B "table" (B "strs" (B "reuse" N N) N) (B "transfer" (B "tokenizer" N N) N)) (B "where" (B "variants" (B "var" N N) N) (B "with" N N))))
-  treeFind (B a t left right) | s < a  = treeFind left
-                              | s > a  = treeFind right
-                              | s == a = t
 
-resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
+data BTree = N | B String BTree BTree deriving (Show)
-   where b s = B s (TS s)
+
+isInTree :: String -> BTree -> Bool
+isInTree x tree = case tree of
+  N -> False
+  B a left right
+   | x < a  -> isInTree x left
+   | x > a  -> isInTree x right
+   | x == a -> True
 
 unescapeInitTail :: String -> String
 unescapeInitTail = unesc . tail where

src/GF/Source/PrintGF.hs

@@ -334,6 +334,7 @@ instance Print Exp where
    EApp exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , prt 3 exp])
    ETable cases -> prPrec i 2 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
    ETTable exp cases -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   EVTable exp exps -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
    ECase exp cases -> prPrec i 2 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
    EVariants exps -> prPrec i 2 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
    EPre exp alterns -> prPrec i 2 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])

src/GF/Source/SkelGF.hs

@@ -206,6 +206,7 @@ transExp x = case x of
   EApp exp0 exp  -> failure x
   ETable cases  -> failure x
   ETTable exp cases  -> failure x
+  EVTable exp exps  -> failure x
   ECase exp cases  -> failure x
   EVariants exps  -> failure x
   EPre exp alterns  -> failure x

src/GF/Source/SourceToGrammar.hs

@@ -350,6 +350,8 @@ transExp x = case x of
   ETable cases  -> liftM (G.T G.TRaw) (transCases cases)
   ETTable exp cases -> 
     liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
+  EVTable exp cases -> 
+    liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
   ECase exp cases  -> do
     exp' <- transExp exp
     cases' <- transCases cases

src/GF/Source/TestGF.hs

@@ -18,22 +18,28 @@ type ParseFun a = [Token] -> Err a
 
 myLLexer = myLexer
 
-runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO ()
+type Verbosity = Int
-runFile p f = readFile f >>= run p
 
-run :: (Print a, Show a) => ParseFun a -> String -> IO ()
+putStrV :: Verbosity -> String -> IO ()
-run p s = case (p (myLLexer s)) of
+putStrV v s = if v > 1 then putStrLn s else return ()
-           Bad s    -> do  putStrLn "\nParse Failed...\n"
+
+runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+           Bad s    -> do  putStrLn "\nParse              Failed...\n"
+                           putStrV v "Tokens:"
+                           putStrV v $ show ts
                            putStrLn s
            Ok  tree -> do putStrLn "\nParse Successful!"
-                          putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
+                          putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
-                          putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
+                          putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
 
 
 main :: IO ()
 main = do args <- getArgs
           case args of
-            []  -> hGetContents stdin >>= run pGrammar
+            [] -> hGetContents stdin >>= run 2 pGrammar
-            [f] -> runFile pGrammar f
+            "-s":fs -> mapM_ (runFile 0 pGrammar) fs
-            _   -> do progName <- getProgName
+            fs -> mapM_ (runFile 2 pGrammar) fs
-                      putStrLn $ progName ++ ": excess arguments."