From 35009a2911a35f37bc1a4cdecf2b5fa20b3cc57c Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 27 May 2008 20:54:31 +0000 Subject: [PATCH] some fixes in pattern matching in Compute --- src-3.0/GF/Compile/Compute.hs | 142 ++++++++++++---------------------- src-3.0/GF/Grammar/Lookup.hs | 3 +- 2 files changed, 52 insertions(+), 93 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 + 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 + 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