GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

strip some redundant constructors from GF.Grammar.Grammar

Browse Source
This commit is contained in:
krasimir
2009-10-25 18:01:04 +00:00
parent d63be8ac72
commit 6753fdae72
10 changed files with 4 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/GF/Compile/Abstract/Compute.hs
View File

@@ -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

1
src/GF/Compile/Concrete/AppPredefined.hs
View File

@@ -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

11
src/GF/Compile/Concrete/Compute.hs
View File

@@ -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

2
src/GF/Compile/Concrete/TypeCheck.hs
View File

@@ -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

2
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -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

8
src/GF/Grammar/Binary.hs
View File

@@ -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)

6
src/GF/Grammar/Grammar.hs
View File

@@ -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}@

8
src/GF/Grammar/Lookup.hs
View File

@@ -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

21
src/GF/Grammar/Macros.hs
View File

@@ -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

10
src/GF/Grammar/PatternMatch.hs
View File

@@ -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]