Commit bddf9fa8 authored by Finn Teegen's avatar Finn Teegen
Browse files

Fix bug in desugaring of record updates

parent 8c81cdff
...@@ -665,18 +665,20 @@ dsExpr p (RecordUpdate e fs) = do ...@@ -665,18 +665,20 @@ dsExpr p (RecordUpdate e fs) = do
dsExpr p $ Case Flex e (map (uncurry (caseAlt p)) alts) dsExpr p $ Case Flex e (map (uncurry (caseAlt p)) alts)
where ty = typeOf e where ty = typeOf e
pty = predType ty pty = predType ty
TypeConstructor tc = arrowBase ty tc = rootOfType (arrowBase ty)
updateAlt (RecordConstr c _ _ ls tys) updateAlt (RecordConstr c _ _ ls _)
| all (`elem` qls) (map fieldLabel fs)= do | all (`elem` qls2) (map fieldLabel fs)= do
vs <- mapM (freshVar "_#rec") tys
let qc = qualifyLike tc c let qc = qualifyLike tc c
pat = constrPattern pty qc vs vEnv <- getValueEnv
let (qls, tys) = argumentTypes ty qc vEnv
vs <- mapM (freshVar "_#rec") tys
let pat = constrPattern pty qc vs
esMap = map field2Tuple fs esMap = map field2Tuple fs
originalEs = map (uncurry mkVar) vs originalEs = map (uncurry mkVar) vs
maybeEs = map (flip lookup esMap) qls maybeEs = map (flip lookup esMap) qls
es = zipWith fromMaybe originalEs maybeEs es = zipWith fromMaybe originalEs maybeEs
return [(pat, applyConstr pty qc tys es)] return [(pat, applyConstr pty qc tys es)]
where qls = map (qualifyLike tc) ls where qls2 = map (qualifyLike tc) ls
updateAlt _ = return [] updateAlt _ = return []
dsExpr p (Tuple es) = apply (Constructor pty $ qTupleId $ length es) <$> mapM (dsExpr p) es dsExpr p (Tuple es) = apply (Constructor pty $ qTupleId $ length es) <$> mapM (dsExpr p) es
where pty = predType (foldr TypeArrow (tupleType tys) tys) where pty = predType (foldr TypeArrow (tupleType tys) tys)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment