pattern matching optimization; trace of fun in compilation with -v

2 files changed, 24 insertions, 18 deletions

diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
index 24f475f03..d9bd70301 100644
--- a/src/GF/Grammar/Compute.hs
+++ b/src/GF/Grammar/Compute.hs
@@ -141,9 +141,11 @@ computeTermOpt rec gr = comp where
              return $ S t' v' -- if v' is not canonical
 
      S t v -> do
-       t'     <- comp g t
-       v'     <- comp g v
-       case t' of
+      t'     <- comp g t
+      v'     <- comp g v
+      case v' of
+       FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants        
+       _ -> case t' of
          FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
 
          T _ [(PV IW,c)] -> comp g c           --- an optimization
@@ -152,21 +154,21 @@ computeTermOpt rec gr = comp where
          T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
          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
-           ps <- mapM term2patt vs
-           let cc = zip ps ts
-           case v' of
-             FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
-             _ -> case matchPattern cc v' of
-               Ok (c,g') -> comp (g' ++ g) c
-               _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t 
+           case lookup v' (zip vs [0 .. length vs - 1]) of
+             Just i -> comp g $ ts !! i
+             _ -> return $ S t' v' -- if v' is not canonical
+
+         T (TComp _) cs -> do
+           case term2patt v' of
+             Ok p' -> case lookup p' cs of
+               Just u -> comp g u
                _ -> return $ S t' v' -- if v' is not canonical
+             _ -> return $ S t' v'
 
-         T _ cc -> case v' of
-	   FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
-           _ -> case matchPattern cc v' of
+         T _ cc -> 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
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index 804333b14..881f10198 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -29,8 +29,11 @@ import Control.Monad
 
 matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
 matchPattern pts term = 
-  errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
-  findMatch [([p],t) | (p,t) <- pts] [term]
+  if not (isInConstantForm term)
+    then prtBad "variables occur in" term
+  else 
+    errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
+    findMatch [([p],t) | (p,t) <- pts] [term]
 
 testOvershadow :: [Patt] -> [Term] -> Err [Patt]
 testOvershadow pts vs = do
@@ -54,14 +57,15 @@ tryMatch (p,t) = do
   t' <- termForm t
   trym p t'
  where
+  isInConstantFormt = True -- tested already
   trym p t' =
     case (p,t') of
       (PVal _ i, (_,Val _ j,_)) 
           | i == j -> return []
           | otherwise -> Bad $ "no match of values"
       (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
-      (PV IW, _) | isInConstantForm t -> return [] -- optimization with wildcard
-      (PV x,  _) | isInConstantForm t -> return [(x,t)]
+      (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
+      (PV x,  _) | isInConstantFormt -> return [(x,t)]
       (PString s, ([],K i,[])) | s==i -> return []
       (PInt s, ([],EInt i,[])) | s==i -> return []
       (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?