data structures for param values with number, preparing optimized pattern matching in grammar compilation

8 files changed, 35 insertions, 38 deletions

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index c93788cd2..5b9e6d923 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -455,7 +455,7 @@ inferLType gr trm = case trm of
        prtFail "cannot infer type of canonical constant" trm
        ]
 
-   Val ty i -> termWith trm $ return ty
+   Val _ ty i -> termWith trm $ return ty
 
    Vr ident -> termWith trm $ checkLookup ident
 
diff --git a/src/GF/Compile/Compute.hs b/src/GF/Compile/Compute.hs
index 3c7c061fc..a33522829 100644
--- a/src/GF/Compile/Compute.hs
+++ b/src/GF/Compile/Compute.hs
@@ -309,14 +309,21 @@ computeTermOpt rec gr = comput True where
          T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
 
          -- course-of-values table: look up by index, no pattern matching needed
-         V ptyp ts -> do
-           vs <- allParamValues gr ptyp
-           case lookupR v' (zip vs [0 .. length vs - 1]) of
-             Just i -> comp g $ ts !! i
-             _ -> return $ S t' v' -- if v' is not canonical
-         T _ cc -> case matchPattern cc v' of
+
+         V ptyp ts -> case v' of
+           Val _ _ i -> comp g $ ts !! i
+           _ -> do
+             vs <- allParamValues gr ptyp
+             case lookupR v' (zip vs [0 .. length vs - 1]) of
+               Just i -> comp g $ ts !! i
+               _ -> return $ S t' v' -- if v' is not canonical
+         T _ cc -> do
+           let v2 = case v' of
+                 Val te _ _ -> te
+                 _ -> v'
+           case matchPattern cc v2 of
              Ok (c,g') -> comp (g' ++ g) c
-             _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t 
+             _ | isCan v2 -> prtBad ("missing case" +++ prt v2 +++ "in") t 
              _ -> return $ S t' v' -- if v' is not canonical
 
          S (T i cs) e -> prawitz g i (flip S v') cs e
@@ -348,8 +355,8 @@ computeTermOpt rec gr = comput True where
            pty0 <- getTableType i
            ptyp <- comp g pty0
            case allParamValues gr ptyp of
-             Ok vs -> do
-
+             Ok vs0 -> do
+               let vs = [Val v ptyp i | (v,i) <- zip vs0 [0..]]
                ps0  <- mapM (compPatternMacro . fst) cs
                cs'  <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
                sts  <- mapM (matchPattern cs') vs 
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index 539e5834c..27081ec94 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -445,25 +445,6 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
    --- this is mainly needed for parameter record projections
    ---- was: 
    comp t = errVal t $ Compute.computeConcreteRec cgr t
-   compt t = case t of
-     T (TComp typ) ts  -> comp $ V typ (map (comp . snd) ts)  ---- should...
-     T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts)  ---- should
-     V typ ts -> V typ (map comp ts)
-     S tb (FV ts) -> FV $ map (comp . S tb) ts
-     S tb@(V typ ts) v0 -> err error id $ do
-       let v = comp v0 
-       let mv1 = Map.lookup v untyps
-       case mv1 of 
-         Just v0 -> 
-           let v1 = fromInteger v0
-               v2 = v1 --if length ts > v1 then v1 
-                       --else trace ("DEBUG" +++ show v1 +++ "of" +++ show ts) 0
-           in return $ (comp . (ts !!)) v2 
-         _ -> return (S (comp tb) v) 
-                  
-     R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r]
-     P (R r) l -> maybe t (comp . snd) $ lookup l r
-     _ -> GM.composSafeOp comp t
 
    doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
    doVar tr = case getLab tr of
@@ -511,6 +492,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
      _ | tr == x -> t
      _ -> GM.composSafeOp (mkBranch x t) tr     
 
+   valNum (Val _ _ i) = EInt $ toInteger i
    valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
     where
       tryFV tr = case GM.appForm tr of
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index 5259e5618..a3735c32f 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -156,7 +156,7 @@ data Term =
  | TSh TInfo [Cases]    -- ^ table with disjunctive patters (only back end opt)
  | V Type [Term]        -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
  | S Term Term          -- ^ selection:   @t ! p@
- | Val Type Int         -- ^ parameter value number: @T # i#
+ | Val Term Type Int    -- ^ parameter value number: @T # i#
 
  | Let LocalDef Term    -- ^ local definition: @let {t : T = a} in b@
 
@@ -194,7 +194,7 @@ data Patt =
  | PFloat Double          -- ^ float literal pattern: @1.2@    -- only abstract
  | PT Type Patt           -- ^ type-annotated pattern
 
- | PVal Type Int          -- ^ parameter value number: @T # i#
+ | PVal Patt Type Int     -- ^ parameter value number: @T # i#
 
  | PAs Ident Patt         -- ^ as-pattern: x@p
 
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index b8c6a2a19..4a11a0d3f 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -178,7 +178,7 @@ lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
 lookupValueIndex gr ty tr = do
   ts <- allParamValues gr ty
   case lookup tr $ zip ts [0..] of
-    Just i -> return $ Val ty i
+    Just i -> return $ Val tr ty i
     _ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty
 
 lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index be03c02a7..065dcef60 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -437,7 +437,9 @@ linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
 term2patt :: Term -> Err Patt
 term2patt trm = case termForm trm of
   Ok ([], Vr x, []) -> return (PV x)
-  Ok ([], Val ty x, []) -> return (PVal ty x)
+  Ok ([], Val te ty x, []) -> do
+    te' <- term2patt te
+    return (PVal te' ty x)
   Ok ([], Con c, aa) -> do
     aa' <- mapM term2patt aa
     return (PC c aa')
@@ -488,7 +490,7 @@ patt2term :: Patt -> Term
 patt2term pt = case pt of
   PV x      -> Vr x
   PW        -> Vr identW             --- not parsable, should not occur
-  PVal t i  -> Val t i
+  PVal v t i -> Val (patt2term v) t i
   PMacro c  -> Cn c
   PM p c    -> Q p c
 
@@ -623,9 +625,10 @@ composOp co trm =
         vs' <- mapM co vs
         return (V ty' vs')
 
-   Val ty i ->
-     do ty' <- co ty
-        return (Val ty' i)
+   Val te ty i ->
+     do te' <- co te
+        ty' <- co ty
+        return (Val te' ty' i)
 
    Let (x,(mt,a)) b -> 
      do a'  <- co a
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index 92d75f2d3..e576dc12e 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -75,9 +75,11 @@ tryMatch (p,t) = do
   isInConstantFormt = True -- tested already in matchPattern
   trym p t' =
     case (p,t') of
-      (PVal _ i, (_,Val _ j,_)) 
+      (PVal _ _ i, (_,Val _ _ j,_)) 
           | i == j -> return []
           | otherwise -> Bad $ "no match of values"
+      (PVal pa _ _,_) -> trym pa t'
+      (_, (_,Val te _ _,_)) -> tryMatch (p, te)
       (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
       (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
       (PV x,  _) | isInConstantFormt -> return [(x,t)]
@@ -151,6 +153,7 @@ isInConstantForm trm = case trm of
     Empty    -> True
     Alias _ _ t -> isInConstantForm t
     EInt _   -> True
+    Val _ _ _ -> True
     _       -> False ---- isInArgVarForm trm
 
 varsOfPatt :: Patt -> [Ident]
diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
index fa879cf23..73b0feafd 100644
--- a/src/GF/Source/GrammarToSource.hs
+++ b/src/GF/Source/GrammarToSource.hs
@@ -201,6 +201,7 @@ trt trm = case trm of
     FV ts -> P.EVariants $ map trt ts
     Strs tt -> P.EStrs $ map trt tt
     EData -> P.EData
+    Val te _ _ -> trt te ----
     _ -> error $ "not yet" +++ show trm ----
 
 trp :: Patt -> P.Patt
@@ -228,6 +229,7 @@ trp p = case p of
     PChars s -> P.PChars s
     PM m c   -> P.PM (tri m) (tri c)
 
+    PVal p _ _ -> trp p ----
 
 trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
   where