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

compile record expansions with let bindings to avoid duplication

Browse Source
This commit is contained in:
krangelov
2021-12-14 15:27:53 +01:00
parent f332a03c79
commit 7556662344
1 changed files with 15 additions and 13 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -225,12 +225,7 @@ inferLType gr g trm = case trm of
return (RecType (zip ls ts'), typeType)
ExtR r s -> do
--- over <- getOverload gr g Nothing r
--- let r1 = maybe r fst over
let r1 = r ---
(r',rT) <- inferLType gr g r1
(r',rT) <- inferLType gr g r
rT' <- computeLType gr g rT
(s',sT) <- inferLType gr g s
@@ -568,14 +563,21 @@ checkLType gr g trm typ0 = do
(r',_) <- checkLType gr g r (RecType fields1)
(s',_) <- checkLType gr g s (RecType fields2)
let project t l =
case t of
R rs -> case lookup l rs of
Just (_,t) -> t
Nothing -> error (render ("no value for label" <+> l))
t -> P t l
let withProjection t fields g f =
case t of
R rs -> f g (\l -> case lookup l rs of
Just (_,t) -> t
Nothing -> error (render ("no value for label" <+> l)))
QC _ -> f g (\l -> P t l)
Vr _ -> f g (\l -> P t l)
_ -> if length fields == 1
then f g (\l -> P t l)
else let x = mkFreshVar (map (\(_,v,_)->v) g)
in Let (x, (Nothing, t)) (f ((Explicit,x,RecType fields):g) (\l -> P (Vr x) l))
rec = R ([(l,(Nothing,project r' l)) | (l,_) <- fields1] ++ [(l,(Nothing,project s' l)) | (l,_) <- fields2])
rec = withProjection r' fields1 g $ \g p_r' ->
withProjection s' fields2 g $ \g p_s' ->
R ([(l,(Nothing,p_r' l)) | (l,_) <- fields1] ++ [(l,(Nothing,p_s' l)) | (l,_) <- fields2])
return (rec, typ)
ExtR ty ex -> do