From 6753fdae72dc6be7cdac5f2ec09fc42d8f0b4b2e Mon Sep 17 00:00:00 2001 From: krasimir Date: Sun, 25 Oct 2009 18:01:04 +0000 Subject: [PATCH] strip some redundant constructors from GF.Grammar.Grammar --- src/GF/Compile/Abstract/Compute.hs | 1 - src/GF/Compile/Concrete/AppPredefined.hs | 1 - src/GF/Compile/Concrete/Compute.hs | 11 +++-------- src/GF/Compile/Concrete/TypeCheck.hs | 2 -- src/GF/Compile/GrammarToGFCC.hs | 2 -- src/GF/Grammar/Binary.hs | 8 -------- src/GF/Grammar/Grammar.hs | 6 ------ src/GF/Grammar/Lookup.hs | 8 -------- src/GF/Grammar/Macros.hs | 21 +-------------------- src/GF/Grammar/PatternMatch.hs | 10 ---------- 10 files changed, 4 insertions(+), 66 deletions(-) diff --git a/src/GF/Compile/Abstract/Compute.hs b/src/GF/Compile/Abstract/Compute.hs index 29cc73525..d5c9a163c 100644 --- a/src/GF/Compile/Abstract/Compute.hs +++ b/src/GF/Compile/Abstract/Compute.hs @@ -123,7 +123,6 @@ tryMatch (p,t) = do matches <- mapM tryMatch (zip pp tt) return (concat matches) (PT _ p',_) -> trym p' t' - (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) (PAs x p',_) -> do subst <- trym p' t' return $ (x,t) : subst diff --git a/src/GF/Compile/Concrete/AppPredefined.hs b/src/GF/Compile/Concrete/AppPredefined.hs index 154d76821..95effb51d 100644 --- a/src/GF/Compile/Concrete/AppPredefined.hs +++ b/src/GF/Compile/Concrete/AppPredefined.hs @@ -136,7 +136,6 @@ trm2str :: Term -> Err Term trm2str t = case t of R ((_,(_,s)):_) -> trm2str s T _ ((_,s):_) -> trm2str s - TSh _ ((_,s):_) -> trm2str s V _ (s:_) -> trm2str s C _ _ -> return $ t K _ -> return $ t diff --git a/src/GF/Compile/Concrete/Compute.hs b/src/GF/Compile/Concrete/Compute.hs index 5a232a2a4..dc4937509 100644 --- a/src/GF/Compile/Concrete/Compute.hs +++ b/src/GF/Compile/Concrete/Compute.hs @@ -311,20 +311,15 @@ computeTermOpt rec gr = comput True where -- course-of-values table: look up by index, no pattern matching needed - V ptyp ts -> case v' of - Val _ _ i -> comp g $ ts !! i - _ -> do + 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 -> do - let v2 = case v' of - Val te _ _ -> te - _ -> v' - case matchPattern cc v2 of + case matchPattern cc v' of Ok (c,g') -> comp (g' ++ g) c - _ | isCan v2 -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v2 <+> text "in" <+> ppTerm Unqualified 0 t)) + _ | isCan v' -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v' <+> text "in" <+> ppTerm Unqualified 0 t)) _ -> return $ S t' v' -- if v' is not canonical S (T i cs) e -> prawitz g i (flip S v') cs e diff --git a/src/GF/Compile/Concrete/TypeCheck.hs b/src/GF/Compile/Concrete/TypeCheck.hs index e5d2a9160..0d72b3c67 100644 --- a/src/GF/Compile/Concrete/TypeCheck.hs +++ b/src/GF/Compile/Concrete/TypeCheck.hs @@ -90,8 +90,6 @@ inferLType gr g trm = case trm of checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) ] - Val _ ty i -> termWith trm $ return ty - Vr ident -> termWith trm $ checkLookup ident g Typed e t -> do diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 2a31d2b75..c284b176c 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -173,7 +173,6 @@ mkTerm tr = case tr of EInt i -> C.C $ fromInteger i R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] P t l -> C.P (mkTerm t) (C.C (mkLab l)) - TSh _ _ -> error $ show tr T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ V _ cs -> C.R [mkTerm t | t <- cs] S t p -> C.P (mkTerm t) (mkTerm p) @@ -507,7 +506,6 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of _ | tr == x -> t _ -> GM.composSafeOp (mkBranch x t) tr - valNum (Val _ _ i) = traceD (show i) $ EInt $ toInteger i ----Val 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/Binary.hs b/src/GF/Grammar/Binary.hs index e22e1dc87..6f5d8b817 100644 --- a/src/GF/Grammar/Binary.hs +++ b/src/GF/Grammar/Binary.hs @@ -140,12 +140,9 @@ instance Binary Term where put (ExtR x y) = putWord8 20 >> put (x,y) put (Table x y) = putWord8 21 >> put (x,y) put (T x y) = putWord8 22 >> put (x,y) - put (TSh x y) = putWord8 23 >> put (x,y) put (V x y) = putWord8 24 >> put (x,y) put (S x y) = putWord8 25 >> put (x,y) - put (Val x y z) = putWord8 26 >> put (x,y,z) put (Let x y) = putWord8 27 >> put (x,y) - put (Alias x y z) = putWord8 28 >> put (x,y,z) put (Q x y) = putWord8 29 >> put (x,y) put (QC x y) = putWord8 30 >> put (x,y) put (C x y) = putWord8 31 >> put (x,y) @@ -180,12 +177,9 @@ instance Binary Term where 20 -> get >>= \(x,y) -> return (ExtR x y) 21 -> get >>= \(x,y) -> return (Table x y) 22 -> get >>= \(x,y) -> return (T x y) - 23 -> get >>= \(x,y) -> return (TSh x y) 24 -> get >>= \(x,y) -> return (V x y) 25 -> get >>= \(x,y) -> return (S x y) - 26 -> get >>= \(x,y,z) -> return (Val x y z) 27 -> get >>= \(x,y) -> return (Let x y) - 28 -> get >>= \(x,y,z) -> return (Alias x y z) 29 -> get >>= \(x,y) -> return (Q x y) 30 -> get >>= \(x,y) -> return (QC x y) 31 -> get >>= \(x,y) -> return (C x y) @@ -208,7 +202,6 @@ instance Binary Patt where put (PInt x) = putWord8 6 >> put x put (PFloat x) = putWord8 7 >> put x put (PT x y) = putWord8 8 >> put (x,y) - put (PVal x y z) = putWord8 9 >> put (x,y,z) put (PAs x y) = putWord8 10 >> put (x,y) put (PNeg x) = putWord8 11 >> put x put (PAlt x y) = putWord8 12 >> put (x,y) @@ -229,7 +222,6 @@ instance Binary Patt where 6 -> get >>= \x -> return (PInt x) 7 -> get >>= \x -> return (PFloat x) 8 -> get >>= \(x,y) -> return (PT x y) - 9 -> get >>= \(x,y,z) -> return (PVal x y z) 10 -> get >>= \(x,y) -> return (PAs x y) 11 -> get >>= \x -> return (PNeg x) 12 -> get >>= \(x,y) -> return (PAlt x y) diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs index a4223585a..70153c454 100644 --- a/src/GF/Grammar/Grammar.hs +++ b/src/GF/Grammar/Grammar.hs @@ -136,15 +136,11 @@ data Term = | Table Term Term -- ^ table type: @P => A@ | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ - | 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 Term Type Int -- ^ parameter value number: @T # i# | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ - | Alias Ident Type Term -- ^ constant and its definition, used in inlining - | Q Ident Ident -- ^ qualified constant from a package | QC Ident Ident -- ^ qualified constructor from a package @@ -175,8 +171,6 @@ data Patt = | PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract | PT Type Patt -- ^ type-annotated pattern - | PVal Patt Type Int -- ^ parameter value number: @T # i# - | PAs Ident Patt -- ^ as-pattern: x@p | PImplArg Patt -- ^ placeholder for pattern for implicit argument @{p}@ diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index 62796aeed..19dde6d09 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -27,7 +27,6 @@ module GF.Grammar.Lookup ( lookupParams, lookupParamValues, lookupFirstTag, - lookupValueIndex, lookupIndexValue, allOrigInfos, allParamValues, @@ -183,13 +182,6 @@ lookupFirstTag gr m c = do v:_ -> return v _ -> Bad (render (text "no parameter values given to type" <+> ppIdent c)) -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 tr ty i - _ -> Bad $ render (text "no index for" <+> ppTerm Unqualified 0 tr <+> text "in" <+> ppTerm Unqualified 0 ty) - lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term lookupIndexValue gr ty i = do ts <- allParamValues gr ty diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index 7aa61c2c9..9062fb2b5 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -329,9 +329,6 @@ term2patt :: Term -> Err Patt term2patt trm = case termForm trm of Ok ([], Vr x, []) | x == identW -> return PW | otherwise -> return (PV 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') @@ -382,7 +379,6 @@ patt2term :: Patt -> Term patt2term pt = case pt of PV x -> Vr x PW -> Vr identW --- not parsable, should not occur - PVal v t i -> Val (patt2term v) t i PMacro c -> Cn c PM p c -> Q p c @@ -441,7 +437,6 @@ strsFromTerm t = case t of ] FV ts -> mapM strsFromTerm ts >>= return . concat Strs ts -> mapM strsFromTerm ts >>= return . concat - Alias _ _ d -> strsFromTerm d --- should not be needed... _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg @@ -502,21 +497,11 @@ composOp co trm = i' <- changeTableType co i return (T i' cc') - TSh i cc -> - do cc' <- mapPairListM (co . snd) cc - i' <- changeTableType co i - return (TSh i' cc') - V ty vs -> do ty' <- co ty vs' <- mapM co vs return (V ty' vs') - 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 mt' <- case mt of @@ -524,10 +509,7 @@ composOp co trm = _ -> return mt b' <- co b return (Let (x,(mt',a')) b') - Alias c ty d -> - do v <- co d - ty' <- co ty - return $ Alias c ty' v + C s1 s2 -> do v1 <- co s1 v2 <- co s2 @@ -583,7 +565,6 @@ collectOp co trm = case trm of RecType r -> concatMap (co . snd) r P t i -> co t T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot - TSh _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot V _ cc -> concatMap co cc --- nor from type annot Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b C s1 s2 -> co s1 ++ co s2 diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs index 828a2e365..b8f7eff7d 100644 --- a/src/GF/Grammar/PatternMatch.hs +++ b/src/GF/Grammar/PatternMatch.hs @@ -76,11 +76,6 @@ tryMatch (p,t) = do isInConstantFormt = True -- tested already in matchPattern trym p t' = case (p,t') of - (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 "" = [""] = [] (PW, _) | isInConstantFormt -> return [] -- optimization with wildcard (PV x, _) | isInConstantFormt -> return [(x,t)] @@ -110,9 +105,6 @@ tryMatch (p,t) = do [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] return (concat matches) (PT _ p',_) -> trym p' t' - (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) - --- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do (PAs x p',_) -> do subst <- trym p' t' @@ -152,9 +144,7 @@ isInConstantForm trm = case trm of R r -> all (isInConstantForm . snd . snd) r K _ -> True Empty -> True - Alias _ _ t -> isInConstantForm t EInt _ -> True - Val _ _ _ -> True _ -> False ---- isInArgVarForm trm varsOfPatt :: Patt -> [Ident]