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