-val optimization

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)) }
-\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+$l $i*   { tok (\p s -> PT p (eitherResIdent TV 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
- | TL !String     -- string literals
- | TI !String     -- integer literals
- | TV !String     -- identifiers
- | TD !String     -- double precision float literals
- | TC !String     -- character literals
+   TS String     -- reserved words
+ | TL String     -- string literals
+ | TI String     -- integer literals
+ | TV String     -- identifiers
+ | TD String     -- double precision float 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
-  where
-  treeFind N = tv s
-  treeFind (B a t left right) | s < a  = treeFind left
-                              | s > a  = treeFind right
-                              | s == a = t
+eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
+  isResWord s = isInTree 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)))
 
-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)))
-   where b s = B s (TS s)
+data BTree = N | B String BTree BTree deriving (Show)
+
+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 ()
-runFile p f = readFile f >>= run p
+type Verbosity = Int
 
-run :: (Print a, Show a) => ParseFun a -> String -> IO ()
-run p s = case (p (myLLexer s)) of
-           Bad s    -> do  putStrLn "\nParse Failed...\n"
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+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
-                          putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
+                          putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
+                          putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
 
 
 main :: IO ()
 main = do args <- getArgs
           case args of
-            []  -> hGetContents stdin >>= run pCanon
-            [f] -> runFile pCanon f
-            _   -> do progName <- getProgName
-                      putStrLn $ progName ++ ": excess arguments."
+            [] -> hGetContents stdin >>= run 2 pCanon
+            "-s":fs -> mapM_ (runFile 0 pCanon) fs
+            fs -> mapM_ (runFile 2 pCanon) fs