some fixes in pattern matching in Compute

2 files changed, 53 insertions, 94 deletions

diff --git a/src-3.0/GF/Compile/Compute.hs b/src-3.0/GF/Compile/Compute.hs
index e42efba8c..73ba202fa 100644
--- a/src-3.0/GF/Compile/Compute.hs
+++ b/src-3.0/GF/Compile/Compute.hs
@@ -129,36 +129,21 @@ computeTermOpt rec gr = comput True where
              _ -> comp g (P b l)
 --- - } ---
 
-         Alias _ _ r -> comp g (P r l)
-
          S (T i cs) e -> prawitz g i (flip P l) cs e
          S (V i cs) e -> prawitzV g i (flip P l) cs e
 
          _   -> returnC $ P t' l
 
      PI t l i -> comp g $ P t l -----
--- {-
-     S t@(T ti cc) v -> do
-       v'     <- comp g v
-       case v' of
-         FV vs -> do
-           ts' <- mapM (comp g . S t) vs
-           return $ variants ts' 
-         _ -> case matchPattern cc v' of
-           Ok (c,g') -> comp (g' ++ g) c
-           _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t 
-           _ -> do
-             t' <- comp g t
-             return $ S t' v' -- if v' is not canonical
--- -}
 
      S t v -> do
-       t' <- compTable True g t
+       t' <- compTable g t
        v' <- comp g v
-       t1 <- case getArgType t' of
-           Ok (RecType fs) -> uncurrySelect gr fs t' v'
+       t1 <- case t' of
+----           V (RecType fs) _         -> uncurrySelect g fs t' v'
+----           T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v'
            _ -> return $ S t' v'
-       compSelect g $ S t' v' 
+       compSelect g t1
 
      -- normalize away empty tokens
      K "" -> return Empty
@@ -175,9 +160,6 @@ computeTermOpt rec gr = comput True where
            xks <- mapM (comp g . Glue x) ks
            return $ variants xks
 
-         (Alias _ _ d, y)  -> comp g $ Glue d y
-         (x, Alias _ _ d)  -> comp g $ Glue x d
-
          (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
          (s, S (T i cs) e) -> prawitz g i (Glue s) cs e
          (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
@@ -233,22 +215,12 @@ computeTermOpt rec gr = comput True where
        r' <- comp g r
        s' <- comp g s
        case (r',s') of
-         (Alias _ _ d, _)  -> comp g $ ExtR d s'
-         (_, Alias _ _ d)  -> comp g $ Glue r' d
-
          (R rs, R ss) -> plusRecord r' s'
          (RecType rs, RecType ss) -> plusRecType r' s'
          _ -> return $ ExtR r' s'
 
-     T _ _ -> compTable False g t
-     V _ _ -> compTable False g t
-
-     --- this means some extra work; should implement TSh directly
-     --- obsolete: TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
-
-     Alias c a d -> do
-       d' <- comp g d
-       return $ Alias c a d'  -- alias only disappears in certain redexes
+     T _ _ -> compTable g t
+     V _ _ -> compTable g t
 
      -- otherwise go ahead
      _ -> composOp (comp g) t >>= returnC
@@ -267,8 +239,6 @@ computeTermOpt rec gr = comput True where
 
          (QC _ _,_)  -> returnC $ App f' a'
 
-         (Alias _ _ d, _) -> comp g (App d a')
-
          (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
          (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
 
@@ -283,19 +253,6 @@ computeTermOpt rec gr = comput True where
        | rec       = lookupResDef gr p c >>= comp []
        | otherwise = lookupResDef gr p c
 
-{-
-     look p c = case lookupResDefKind gr p c of
-       Ok (t,_) | noExpand p || rec -> comp [] t
-       Ok (t,_) -> return t
-       Bad s -> raise s
-
-     noExpand p = errVal False $ do
-       mo <- lookupModMod gr p
-       return $ case getOptVal (iOpts (flags mo)) useOptimizer of
-         Just "noexpand" -> True
-         _ -> False
--}
-
      ext x a g = (x,a):g
 
      returnC = return --- . computed
@@ -354,62 +311,48 @@ computeTermOpt rec gr = comput True where
            vs <- allParamValues gr ptyp
            case lookup v' (zip vs [0 .. length vs - 1]) of
              Just i -> comp g $ ts !! i
------             _ -> prtBad "selection" $ S t' v' -- debug
              _ -> 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 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
 
-         Alias _ _ d -> comp g (S d v')
-
          S (T i cs) e -> prawitz g i (flip S v') cs e
          S (V i cs) e -> prawitzV g i (flip S v') cs e
          _    -> returnC $ S t' v'
 
-
      -- case-expand tables
      -- if already expanded, don't expand again
-     compTable isSel g t = do
-       t2 <- case t of
+     compTable g t = case t of
          T i@(TComp ty) cs -> do
-          -- if there are no variables, don't even go inside
-          cs' <- if (null g) then return cs else mapPairsM (comp g) cs
-----          return $ V ty (map snd cs')
-          return $ T i cs'
+           -- if there are no variables, don't even go inside
+           cs' <- if (null g) then return cs else mapPairsM (comp g) cs
+----           return $ V ty (map snd cs')
+           return $ T i cs'
          V ty cs -> do
-          ty' <- comp g ty
           -- if there are no variables, don't even go inside
           cs' <- if (null g) then return cs else mapM (comp g) cs
-          return $ V ty' cs'
+----       return $ V ty (map snd cs')
+          return $ V ty cs'
 
          T i cs -> do
-          pty0 <- getTableType i
-          ptyp <- comp g pty0
-          case allParamValues gr ptyp of
-            Ok vs -> do
-
-              ps0  <- mapM (compPatternMacro . fst) cs
-              cs'  <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
-              sts  <- mapM (matchPattern cs') vs 
-              ts   <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
-              ps   <- mapM term2patt vs
-              let ps' = ps --- PT ptyp (head ps) : tail ps
-----           return $ V ptyp ts -- to save space, just course of values
-              return $ T (TComp ptyp) (zip ps' ts)
-            _ -> do
-              cs' <- mapM (compBranch g) cs
-              return $ T i cs'  -- happens with variable types
+           pty0 <- getTableType i
+           ptyp <- comp g pty0
+           case allParamValues gr ptyp of
+             Ok vs -> do
+
+               ps0  <- mapM (compPatternMacro . fst) cs
+               cs'  <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
+               sts  <- mapM (matchPattern cs') vs 
+               ts   <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
+               ps   <- mapM term2patt vs
+               let ps' = ps --- PT ptyp (head ps) : tail ps
+----               return $ V ptyp ts -- to save space, just course of values
+               return $ T (TComp ptyp) (zip ps' ts)
+             _ -> do
+               cs' <- mapM (compBranch g) cs
+               return $ T i cs'  -- happens with variable types
          _ -> comp g t
-       return t2 ---- $ if isSel then uncurryTable t2 else t2
 
      compBranch g (p,v) = do
        let g' = contP p ++ g
@@ -443,6 +386,28 @@ computeTermOpt rec gr = comput True where
        cs' <- mapM (comp g) [(f v) | v <- cs]
        return $ S (V i cs') e
 
+{- ----
+     uncurrySelect g fs t v = do
+       ts <- mapM (allParamValues gr . snd) fs
+       vs <- mapM (comp g) [P v r | r <- map fst fs]
+       return $ reorderSelect t fs ts vs
+
+     reorderSelect t fs pss vs = case (t,fs,pss,vs) of
+       (V _ ts, f:fs1, ps:pss1, v:vs1) -> 
+         S (V (snd f) 
+             [reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 | 
+               t <- segments (length ts `div` length ps) ts]) v 
+       (T (TComp _) cs, f:fs1, ps:pss1, v:vs1) -> 
+         S (T (TComp (snd f)) 
+             [(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) | 
+               (ep,c) <- zip ps (segments (length cs `div` length ps) cs),
+               let Ok p = term2patt ep]) v 
+       _ -> t
+
+     segments i xs = 
+       let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1)
+-}
+
 
 -- | argument variables cannot be glued
 checkNoArgVars :: Term -> Err Term
@@ -461,9 +426,4 @@ getArgType t = case t of
   _ -> prtBad "cannot get argument type of table" t
 
 
----- uncurryTable gr t = do
-
-uncurrySelect gr fs t v = do
-  return $ S t v ---
-
 
diff --git a/src-3.0/GF/Grammar/Lookup.hs b/src-3.0/GF/Grammar/Lookup.hs
index 3c308a539..35e3b8006 100644
--- a/src-3.0/GF/Grammar/Lookup.hs
+++ b/src-3.0/GF/Grammar/Lookup.hs
@@ -144,7 +144,6 @@ lookupParams gr = look True where
         info <- lookupIdentInfo mo c
         case info of
           ResParam (Yes psm) -> return psm
-
           AnyInd _ n        -> look False n c
           _   -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
       _ -> Bad $ prt m +++ "is not a resource"
@@ -195,7 +194,7 @@ allParamValues :: SourceGrammar -> Type -> Err [Term]
 allParamValues cnc ptyp = case ptyp of
      _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
      QC p c -> lookupParamValues cnc p c
-     Q  p c -> lookupParamValues cnc p c ----
+     Q  p c -> lookupResDef cnc p c >>= allParamValues cnc
      RecType r -> do
        let (ls,tys) = unzip $ sortByFst r
        tss <- mapM allPV tys