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

when a pattern macro is invoked, the operation must be computed first

Browse Source
This commit is contained in:
krangelov
2021-12-13 09:55:37 +01:00
parent f7bf18d101
commit bb053119b3
1 changed files with 31 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

61
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -10,6 +10,7 @@ import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Grammar.PatternMatch
import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
import GF.Compile.Compute.Concrete(normalForm)
import GF.Compile.TypeCheck.Primitives
import Data.List
@@ -267,7 +268,7 @@ inferLType gr g trm = case trm of
return (EPattType ty',typeType)
EPatt _ _ p -> do
ty <- inferPatt p
let (minp,maxp,p') = measurePatt gr p
(minp,maxp,p') <- measurePatt gr p
return (EPatt minp maxp p', EPattType ty)
ELin c trm -> do
@@ -324,35 +325,35 @@ inferLType gr g trm = case trm of
measurePatt gr p =
case p of
PM q -> case lookupResDef gr q of
Ok t -> case t of
EPatt minp maxp _ -> (minp,maxp,p)
_ -> error "Expected pattern macro"
Bad msg -> error msg
PR ass -> let p' = PR (map (\(lbl,p) -> let (_,_,p') = measurePatt gr p in (lbl,p')) ass)
in (0,Nothing,p')
PString s -> let len=length s
in (len,Just len,p)
PT t p -> let (min,max,p') = measurePatt gr p
in (min,max,PT t p')
PAs x p -> let (min,max,p') = measurePatt gr p
in (min,max,PAs x p')
PImplArg p -> let (min,max,p') = measurePatt gr p
in (min,max,PImplArg p')
PNeg p -> let (_,_,p') = measurePatt gr p
in (0,Nothing,PNeg p')
PAlt p1 p2 -> let (min1,max1,p1') = measurePatt gr p1
(min2,max2,p2') = measurePatt gr p2
in (min min1 min2,liftM2 max max1 max2,PAlt p1' p2')
PM q -> do t <- lookupResDef gr q
t <- normalForm gr t
case t of
EPatt minp maxp _ -> return (minp,maxp,p)
_ -> checkError ("Expected pattern macro, but found:" $$ nest 2 (pp t))
PR ass -> do ass <- mapM (\(lbl,p) -> measurePatt gr p >>= \(_,_,p') -> return (lbl,p')) ass
return (0,Nothing,PR ass)
PString s -> do let len=length s
return (len,Just len,p)
PT t p -> do (min,max,p') <- measurePatt gr p
return (min,max,PT t p')
PAs x p -> do (min,max,p') <- measurePatt gr p
return (min,max,PAs x p')
PImplArg p -> do (min,max,p') <- measurePatt gr p
return (min,max,PImplArg p')
PNeg p -> do (_,_,p') <- measurePatt gr p
return (0,Nothing,PNeg p')
PAlt p1 p2 -> do (min1,max1,p1') <- measurePatt gr p1
(min2,max2,p2') <- measurePatt gr p2
return (min min1 min2,liftM2 max max1 max2,PAlt p1' p2')
PSeq _ _ p1 _ _ p2
-> let (min1,max1,p1') = measurePatt gr p1
(min2,max2,p2') = measurePatt gr p2
in (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1' min2 max2 p2')
PRep _ _ p -> let (minp,maxp,p') = measurePatt gr p
in (0,Nothing,PRep minp maxp p')
PChar -> (1,Just 1,p)
PChars _ -> (1,Just 1,p)
_ -> (0,Nothing,p)
-> do (min1,max1,p1') <- measurePatt gr p1
(min2,max2,p2') <- measurePatt gr p2
return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1' min2 max2 p2')
PRep _ _ p -> do (minp,maxp,p') <- measurePatt gr p
return (0,Nothing,PRep minp maxp p')
PChar -> return (1,Just 1,p)
PChars _ -> return (1,Just 1,p)
_ -> return (0,Nothing,p)
-- type inference: Nothing, type checking: Just t
-- the latter permits matching with value type
@@ -632,7 +633,7 @@ checkLType gr g trm typ0 = do
checkCase arg val (p,t) = do
cont <- pattContext gr g arg p
t' <- justCheck (reverse cont ++ g) t val
let (_,_,p') = measurePatt gr p
(_,_,p') <- measurePatt gr p
return (p',t')
pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context