msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

safe pattern matching in the presence of a variable

Browse Source
This commit is contained in:
krangelov
2021-09-29 09:32:09 +02:00
parent 86326d282f
commit 2137324f81
1 changed files with 14 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -154,8 +154,10 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
(PSeq p1 p2,VStr s) (PSeq p1 p2,VStr s)
-> do eqs <- matchStr env (p1:p2:ps) eqs [] [] s [] args -> do eqs <- matchStr env (p1:p2:ps) eqs [] [] s [] args
patternMatch v0 eqs patternMatch v0 eqs
(PSeq p1 p2,VC vs)-> do eqs <- matchSeq env (p1:p2:ps) eqs [] vs args (PSeq p1 p2,VC vs)-> do mb_eqs <- matchSeq env (p1:p2:ps) eqs [] vs args
patternMatch v0 eqs case mb_eqs of
Just eqs -> patternMatch v0 eqs
Nothing -> return v0
(PChar, VStr [_]) -> match env ps eqs args (PChar, VStr [_]) -> match env ps eqs args
(PChars cs, VStr [c]) (PChars cs, VStr [c])
| elem c cs -> match env ps eqs args | elem c cs -> match env ps eqs args
@@ -171,11 +173,16 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args) Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
Nothing -> evalError ("Missing value for label" <+> pp lbl) Nothing -> evalError ("Missing value for label" <+> pp lbl)
matchSeq env ps eqs ws [] args = return eqs matchSeq env ps eqs ws [] args = return (Just eqs)
matchSeq env ps eqs ws (v@(VStr (c:cs)):vs) args = do matchSeq env ps eqs ws (v:vs) args = do
eqs <- matchSeq env ps eqs (v:ws) vs args mb_eqs <- matchSeq env ps eqs (v:ws) vs args
eqs <- matchStr env ps eqs ws [c] cs vs args case v of
return eqs VStr [] -> return mb_eqs
VStr (c:cs) -> case mb_eqs of
Just eqs -> do eqs <- matchStr env ps eqs ws [c] cs vs args
return (Just eqs)
Nothing -> return Nothing
_ -> return Nothing
matchStr env ps eqs ws ds [] vs args = do matchStr env ps eqs ws ds [] vs args = do
arg1 <- newEvaluatedThunk (vc (reverse (VStr (reverse ds):ws))) arg1 <- newEvaluatedThunk (vc (reverse (VStr (reverse ds):ws)))