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

some fixes in pattern matching in Compute

Browse Source
This commit is contained in:
aarne
2008-05-27 20:54:31 +00:00
parent 83dc6de3a8
commit 35009a2911
2 changed files with 52 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files

142
src-3.0/GF/Compile/Compute.hs
View File

@@ -129,36 +129,21 @@ computeTermOpt rec gr = comput True where
_ -> comp g (P b l) _ -> 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 (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 S (V i cs) e -> prawitzV g i (flip P l) cs e
_ -> returnC $ P t' l _ -> returnC $ P t' l
PI t l i -> comp g $ 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 S t v -> do
t' <- compTable True g t t' <- compTable g t
v' <- comp g v v' <- comp g v
t1 <- case getArgType t' of t1 <- case t' of
Ok (RecType fs) -> uncurrySelect gr fs t' v' ---- V (RecType fs) _ -> uncurrySelect g fs t' v'
---- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v'
_ -> return $ S t' v' _ -> return $ S t' v'
compSelect g $ S t' v' compSelect g t1
-- normalize away empty tokens -- normalize away empty tokens
K "" -> return Empty K "" -> return Empty
@@ -175,9 +160,6 @@ computeTermOpt rec gr = comput True where
xks <- mapM (comp g . Glue x) ks xks <- mapM (comp g . Glue x) ks
return $ variants xks 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 (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, 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 (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 r' <- comp g r
s' <- comp g s s' <- comp g s
case (r',s') of 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' (R rs, R ss) -> plusRecord r' s'
(RecType rs, RecType ss) -> plusRecType r' s' (RecType rs, RecType ss) -> plusRecType r' s'
_ -> return $ ExtR r' s' _ -> return $ ExtR r' s'
T _ _ -> compTable False g t T _ _ -> compTable g t
V _ _ -> compTable False g t V _ _ -> compTable 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
-- otherwise go ahead -- otherwise go ahead
_ -> composOp (comp g) t >>= returnC _ -> composOp (comp g) t >>= returnC
@@ -267,8 +239,6 @@ computeTermOpt rec gr = comput True where
(QC _ _,_) -> returnC $ App f' a' (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 (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 (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 [] | rec = lookupResDef gr p c >>= comp []
| otherwise = lookupResDef gr p c | 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 ext x a g = (x,a):g
returnC = return --- . computed returnC = return --- . computed
@@ -354,62 +311,48 @@ computeTermOpt rec gr = comput True where
vs <- allParamValues gr ptyp vs <- allParamValues gr ptyp
case lookup v' (zip vs [0 .. length vs - 1]) of case lookup v' (zip vs [0 .. length vs - 1]) of
Just i -> comp g $ ts !! i Just i -> comp g $ ts !! i
----- _ -> prtBad "selection" $ S t' v' -- debug
_ -> return $ S t' v' -- if v' is not canonical _ -> 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 T _ cc -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical _ -> 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 (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 S (V i cs) e -> prawitzV g i (flip S v') cs e
_ -> returnC $ S t' v' _ -> returnC $ S t' v'
-- case-expand tables -- case-expand tables
-- if already expanded, don't expand again -- if already expanded, don't expand again
compTable isSel g t = do compTable g t = case t of
t2 <- case t of
T i@(TComp ty) cs -> do T i@(TComp ty) cs -> do
-- if there are no variables, don't even go inside -- if there are no variables, don't even go inside
cs' <- if (null g) then return cs else mapPairsM (comp g) cs cs' <- if (null g) then return cs else mapPairsM (comp g) cs
---- return $ V ty (map snd cs') ---- return $ V ty (map snd cs')
return $ T i cs' return $ T i cs'
V ty cs -> do V ty cs -> do
ty' <- comp g ty
-- if there are no variables, don't even go inside -- if there are no variables, don't even go inside
cs' <- if (null g) then return cs else mapM (comp g) cs 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 T i cs -> do
pty0 <- getTableType i pty0 <- getTableType i
ptyp <- comp g pty0 ptyp <- comp g pty0
case allParamValues gr ptyp of case allParamValues gr ptyp of
Ok vs -> do Ok vs -> do
ps0 <- mapM (compPatternMacro . fst) cs ps0 <- mapM (compPatternMacro . fst) cs
cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs)) cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
sts <- mapM (matchPattern cs') vs sts <- mapM (matchPattern cs') vs
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- mapM term2patt vs ps <- mapM term2patt vs
let ps' = ps --- PT ptyp (head ps) : tail ps let ps' = ps --- PT ptyp (head ps) : tail ps
---- return $ V ptyp ts -- to save space, just course of values ---- return $ V ptyp ts -- to save space, just course of values
return $ T (TComp ptyp) (zip ps' ts) return $ T (TComp ptyp) (zip ps' ts)
_ -> do _ -> do
cs' <- mapM (compBranch g) cs cs' <- mapM (compBranch g) cs
return $ T i cs' -- happens with variable types return $ T i cs' -- happens with variable types
_ -> comp g t _ -> comp g t
return t2 ---- $ if isSel then uncurryTable t2 else t2
compBranch g (p,v) = do compBranch g (p,v) = do
let g' = contP p ++ g let g' = contP p ++ g
@@ -443,6 +386,28 @@ computeTermOpt rec gr = comput True where
cs' <- mapM (comp g) [(f v) | v <- cs] cs' <- mapM (comp g) [(f v) | v <- cs]
return $ S (V i cs') e 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 -- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term checkNoArgVars :: Term -> Err Term
@@ -461,9 +426,4 @@ getArgType t = case t of
_ -> prtBad "cannot get argument type of table" t _ -> prtBad "cannot get argument type of table" t
---- uncurryTable gr t = do
uncurrySelect gr fs t v = do
return $ S t v ---

3
src-3.0/GF/Grammar/Lookup.hs
View File

@@ -144,7 +144,6 @@ lookupParams gr = look True where
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
ResParam (Yes psm) -> return psm ResParam (Yes psm) -> return psm
AnyInd _ n -> look False n c AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource" _ -> Bad $ prt m +++ "is not a resource"
@@ -195,7 +194,7 @@ allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of allParamValues cnc ptyp = case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
QC p c -> lookupParamValues cnc p c 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 RecType r -> do
let (ls,tys) = unzip $ sortByFst r let (ls,tys) = unzip $ sortByFst r
tss <- mapM allPV tys tss <- mapM allPV tys