Commit b1c3e141 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Fixed missing polymorphism of record labels - fixes #445

parent 46e02b2d
...@@ -29,10 +29,10 @@ type annotation is present. ...@@ -29,10 +29,10 @@ type annotation is present.
> import qualified Data.Map as Map (Map, empty, insert, lookup) > import qualified Data.Map as Map (Map, empty, insert, lookup)
> import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, listToMaybe, maybeToList) > import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, listToMaybe, maybeToList)
> import qualified Data.Set as Set (Set, fromList, member, notMember, unions) > import qualified Data.Set as Set (Set, fromList, member, notMember, unions)
> import Text.PrettyPrint
> import Curry.Base.Ident > import Curry.Base.Ident
> import Curry.Base.Position > import Curry.Base.Position
> import Curry.Base.Pretty
> import Curry.Syntax > import Curry.Syntax
> import Curry.Syntax.Pretty > import Curry.Syntax.Pretty
...@@ -623,16 +623,14 @@ signature the declared type must be too general. ...@@ -623,16 +623,14 @@ signature the declared type must be too general.
> tcPattern p (FunctionPattern op [t1,t2]) > tcPattern p (FunctionPattern op [t1,t2])
> tcPattern p r@(RecordPattern fs rt) > tcPattern p r@(RecordPattern fs rt)
> | isJust rt = do > | isJust rt = do
> m <- getModuleIdent
> ty <- tcPattern p (fromJust rt) > ty <- tcPattern p (fromJust rt)
> fts <- mapM (tcFieldPatt tcPattern m) fs > fts <- mapM (tcFieldPatt tcPattern) fs
> alpha <- freshVar id > alpha <- freshVar id
> let rty = TypeRecord fts (Just alpha) > let rty = TypeRecord fts (Just alpha)
> unify p "record pattern" (ppPattern 0 r) ty rty > unify p "record pattern" (ppPattern 0 r) ty rty
> return rty > return rty
> | otherwise = do > | otherwise = do
> m <- getModuleIdent > fts <- mapM (tcFieldPatt tcPattern) fs
> fts <- mapM (tcFieldPatt tcPattern m) fs
> return (TypeRecord fts Nothing) > return (TypeRecord fts Nothing)
\end{verbatim} \end{verbatim}
...@@ -644,7 +642,7 @@ because of possibly multiple occurrences of variables. ...@@ -644,7 +642,7 @@ because of possibly multiple occurrences of variables.
> tcPatternFP :: Position -> Pattern -> TCM Type > tcPatternFP :: Position -> Pattern -> TCM Type
> tcPatternFP _ (LiteralPattern l) = tcLiteral l > tcPatternFP _ (LiteralPattern l) = tcLiteral l
> tcPatternFP _ (NegativePattern _ l) = tcLiteral l > tcPatternFP _ (NegativePattern _ l) = tcLiteral l
> tcPatternFP _ (VariablePattern v) = do > tcPatternFP _ (VariablePattern v) = do
> sigs <- getSigEnv > sigs <- getSigEnv
> m <- getModuleIdent > m <- getModuleIdent
> ty <- case lookupTypeSig v sigs of > ty <- case lookupTypeSig v sigs of
...@@ -720,34 +718,31 @@ because of possibly multiple occurrences of variables. ...@@ -720,34 +718,31 @@ because of possibly multiple occurrences of variables.
> tcPatternFP p (FunctionPattern op [t1,t2]) > tcPatternFP p (FunctionPattern op [t1,t2])
> tcPatternFP p r@(RecordPattern fs rt) > tcPatternFP p r@(RecordPattern fs rt)
> | isJust rt = do > | isJust rt = do
> m <- getModuleIdent
> ty <- tcPatternFP p (fromJust rt) > ty <- tcPatternFP p (fromJust rt)
> fts <- mapM (tcFieldPatt tcPatternFP m) fs > fts <- mapM (tcFieldPatt tcPatternFP) fs
> alpha <- freshVar id > alpha <- freshVar id
> let rty = TypeRecord fts (Just alpha) > let rty = TypeRecord fts (Just alpha)
> unify p "record pattern" (ppPattern 0 r) ty rty > unify p "record pattern" (ppPattern 0 r) ty rty
> return rty > return rty
> | otherwise = do > | otherwise = do
> m <- getModuleIdent > fts <- mapM (tcFieldPatt tcPatternFP) fs
> fts <- mapM (tcFieldPatt tcPatternFP m) fs
> return (TypeRecord fts Nothing) > return (TypeRecord fts Nothing)
> tcFieldPatt :: (Position -> Pattern -> TCM Type) -> ModuleIdent > tcFieldPatt :: (Position -> Pattern -> TCM Type) -> Field Pattern
> -> Field Pattern -> TCM (Ident, Type) > -> TCM (Ident, Type)
> tcFieldPatt tcPatt m f@(Field _ l t) = do > tcFieldPatt tcPatt f@(Field _ l t) = do
> tyEnv <- getValueEnv > m <- getModuleIdent
> let p = idPosition l > tyEnv <- getValueEnv
> lty <- maybe (freshTypeVar > let p = idPosition l
> >>= (\lty' -> > lty <- maybe (freshTypeVar >>= \lty' ->
> modifyValueEnv > modifyValueEnv
> (bindLabel l (qualifyWith m (mkIdent "#Rec")) > (bindLabel l (qualifyWith m (mkIdent "#Rec")) (polyType lty'))
> (polyType lty')) > >> return lty')
> >> return lty')) > inst
> (\ (ForAll _ lty') -> return lty') > (sureLabelType l tyEnv)
> (sureLabelType l tyEnv) > ty <- tcPatt p t
> ty <- tcPatt p t > unify p "record" (text "Field:" <+> ppFieldPatt f) lty ty
> unify p "record" (text "Field:" <+> ppFieldPatt f) lty ty > return (l, ty)
> return (l,ty)
> tcRhs ::ValueEnv -> Rhs -> TCM Type > tcRhs ::ValueEnv -> Rhs -> TCM Type
> tcRhs tyEnv0 (SimpleRhs p e ds) = do > tcRhs tyEnv0 (SimpleRhs p e ds) = do
...@@ -761,38 +756,34 @@ because of possibly multiple occurrences of variables. ...@@ -761,38 +756,34 @@ because of possibly multiple occurrences of variables.
> tcCondExprs :: ValueEnv -> [CondExpr] -> TCM Type > tcCondExprs :: ValueEnv -> [CondExpr] -> TCM Type
> tcCondExprs tyEnv0 es = do > tcCondExprs tyEnv0 es = do
> gty <- if length es > 1 then return boolType > gty <- if length es > 1 then return boolType
> else freshConstrained [successType,boolType] > else freshConstrained [successType, boolType]
> ty <- freshTypeVar > ty <- freshTypeVar
> tcCondExprs' gty ty es > mapM_ (tcCondExpr gty ty) es
> where tcCondExprs' _ ty [] = return ty > return ty
> tcCondExprs' gty ty (e1:es1) = > where
> tcCondExpr gty ty e1 >> tcCondExprs' gty ty es1 > tcCondExpr gty ty (CondExpr p g e) = do
> tcCondExpr gty ty (CondExpr p g e) = do > tcExpr p g >>= unify p "guard" (ppExpr 0 g) gty
> tcExpr p g >>= > tcExpr p e >>= checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0
> unify p "guard" (ppExpr 0 g) gty >> > >>= unify p "guarded expression" (ppExpr 0 e) ty
> tcExpr p e >>=
> checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 >>=
> unify p "guarded expression" (ppExpr 0 e) ty
> tcExpr :: Position -> Expression -> TCM Type > tcExpr :: Position -> Expression -> TCM Type
> tcExpr _ (Literal l) = tcLiteral l > tcExpr _ (Literal l) = tcLiteral l
> tcExpr _ (Variable v) > tcExpr _ (Variable v)
> -- anonymous free variable > | isAnonId v' = do -- anonymous free variable
> | isAnonId v' = do > m <- getModuleIdent
> m <- getModuleIdent > ty <- freshTypeVar
> ty <- freshTypeVar > modifyValueEnv $ bindFun m v' (arrowArity ty) $ monoType ty
> modifyValueEnv $ bindFun m v' (arrowArity ty) $ monoType ty > return ty
> return ty > | otherwise = do
> | otherwise = do > sigs <- getSigEnv
> sigs <- getSigEnv > m <- getModuleIdent
> m <- getModuleIdent > case qualLookupTypeSig m v sigs of
> case qualLookupTypeSig m v sigs of > Just ty -> expandPolyType ty >>= inst
> Just ty -> expandPolyType ty >>= inst > Nothing -> getValueEnv >>= inst . funType m v
> Nothing -> getValueEnv >>= inst . funType m v
> where v' = unqualify v > where v' = unqualify v
> tcExpr _ (Constructor c) = do > tcExpr _ (Constructor c) = do
> m <- getModuleIdent > m <- getModuleIdent
> getValueEnv >>= instExist . constrType m c > getValueEnv >>= instExist . constrType m c
> tcExpr p (Typed e sig) = do > tcExpr p (Typed e sig) = do
> m <- getModuleIdent > m <- getModuleIdent
> tyEnv0 <- getValueEnv > tyEnv0 <- getValueEnv
...@@ -801,15 +792,16 @@ because of possibly multiple occurrences of variables. ...@@ -801,15 +792,16 @@ because of possibly multiple occurrences of variables.
> inst sigma' >>= flip (unify p "explicitly typed expression" (ppExpr 0 e)) ty > inst sigma' >>= flip (unify p "explicitly typed expression" (ppExpr 0 e)) ty
> theta <- getTypeSubst > theta <- getTypeSubst
> let sigma = gen (fvEnv (subst theta tyEnv0)) (subst theta ty) > let sigma = gen (fvEnv (subst theta tyEnv0)) (subst theta ty)
> unless (sigma == sigma') (report $ errTypeSigTooGeneral p m (text "Expression:" <+> ppExpr 0 e) sig' sigma) > unless (sigma == sigma') $ report $
> errTypeSigTooGeneral p m (text "Expression:" <+> ppExpr 0 e) sig' sigma
> return ty > return ty
> where sig' = nameSigType sig > where sig' = nameSigType sig
> tcExpr p (Paren e) = tcExpr p e > tcExpr p (Paren e) = tcExpr p e
> tcExpr p (Tuple _ es) > tcExpr p (Tuple _ es)
> | null es = return unitType > | null es = return unitType
> | otherwise = liftM tupleType $ mapM (tcExpr p) es > | otherwise = liftM tupleType $ mapM (tcExpr p) es
> tcExpr p e@(List _ es) = freshTypeVar >>= tcElems (ppExpr 0 e) es > tcExpr p e@(List _ es) = freshTypeVar >>= tcElems (ppExpr 0 e) es
> where tcElems _ [] ty = return (listType ty) > where tcElems _ [] ty = return (listType ty)
> tcElems doc (e1:es1) ty = > tcElems doc (e1:es1) ty =
> tcExpr p e1 >>= > tcExpr p e1 >>=
> unify p "expression" (doc $-$ text "Term:" <+> ppExpr 0 e1) > unify p "expression" (doc $-$ text "Term:" <+> ppExpr 0 e1)
...@@ -821,118 +813,118 @@ because of possibly multiple occurrences of variables. ...@@ -821,118 +813,118 @@ because of possibly multiple occurrences of variables.
> ty <- tcExpr p e > ty <- tcExpr p e
> checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 (listType ty) > checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 (listType ty)
> tcExpr p e@(EnumFrom e1) = do > tcExpr p e@(EnumFrom e1) = do
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1
> return (listType intType) > return (listType intType)
> tcExpr p e@(EnumFromThen e1 e2) = do > tcExpr p e@(EnumFromThen e1 e2) = do
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> ty2 <- tcExpr p e2 > ty2 <- tcExpr p e2
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) intType ty2 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) intType ty2
> return (listType intType) > return (listType intType)
> tcExpr p e@(EnumFromTo e1 e2) = do > tcExpr p e@(EnumFromTo e1 e2) = do
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> ty2 <- tcExpr p e2 > ty2 <- tcExpr p e2
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) intType ty2 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) intType ty2
> return (listType intType) > return (listType intType)
> tcExpr p e@(EnumFromThenTo e1 e2 e3) = do > tcExpr p e@(EnumFromThenTo e1 e2 e3) = do
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> ty2 <- tcExpr p e2 > ty2 <- tcExpr p e2
> ty3 <- tcExpr p e3 > ty3 <- tcExpr p e3
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) intType ty1
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) intType ty2 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) intType ty2
> unify p "arithmetic sequence" > unify p "arithmetic sequence"
> (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3) intType ty3 > (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3) intType ty3
> return (listType intType) > return (listType intType)
> tcExpr p e@(UnaryMinus op e1) = do > tcExpr p e@(UnaryMinus op e1) = do
> opTy <- opType op > opTy <- opType op
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> unify p "unary negation" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) > unify p "unary negation" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
> opTy ty1 > opTy ty1
> return ty1 > return ty1
> where opType op' > where opType op'
> | op' == minusId = freshConstrained [intType,floatType] > | op' == minusId = freshConstrained [intType,floatType]
> | op' == fminusId = return floatType > | op' == fminusId = return floatType
> | otherwise = internalError $ "TypeCheck.tcExpr unary " ++ idName op' > | otherwise = internalError $ "TypeCheck.tcExpr unary " ++ idName op'
> tcExpr p e@(Apply e1 e2) = do > tcExpr p e@(Apply e1 e2) = do
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> ty2 <- tcExpr p e2 > ty2 <- tcExpr p e2
> (alpha,beta) <- > (alpha,beta) <-
> tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) > tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
> ty1 > ty1
> unify p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) > unify p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2)
> alpha ty2 > alpha ty2
> return beta > return beta
> tcExpr p e@(InfixApply e1 op e2) = do > tcExpr p e@(InfixApply e1 op e2) = do
> opTy <- tcExpr p (infixOp op) > opTy <- tcExpr p (infixOp op)
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> ty2 <- tcExpr p e2 > ty2 <- tcExpr p e2
> (alpha,beta,gamma) <- > (alpha,beta,gamma) <-
> tcBinary p "infix application" > tcBinary p "infix application"
> (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) opTy > (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) opTy
> unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) > unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
> alpha ty1 > alpha ty1
> unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) > unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2)
> beta ty2 > beta ty2
> return gamma > return gamma
> tcExpr p e@(LeftSection e1 op) = do > tcExpr p e@(LeftSection e1 op) = do
> opTy <- tcExpr p (infixOp op) > opTy <- tcExpr p (infixOp op)
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> (alpha,beta) <- > (alpha,beta) <-
> tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) > tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)
> opTy > opTy
> unify p "left section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) > unify p "left section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
> alpha ty1 > alpha ty1
> return beta > return beta
> tcExpr p e@(RightSection op e1) = do > tcExpr p e@(RightSection op e1) = do
> opTy <- tcExpr p (infixOp op) > opTy <- tcExpr p (infixOp op)
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> (alpha,beta,gamma) <- > (alpha,beta,gamma) <-
> tcBinary p "right section" > tcBinary p "right section"
> (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) opTy > (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) opTy
> unify p "right section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) > unify p "right section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
> beta ty1 > beta ty1
> return (TypeArrow alpha gamma) > return (TypeArrow alpha gamma)
> tcExpr p expr@(Lambda _ ts e) = do > tcExpr p expr@(Lambda _ ts e) = do
> tyEnv0 <- getValueEnv > tyEnv0 <- getValueEnv
> tys <- mapM (tcPattern p) ts > tys <- mapM (tcPattern p) ts
> ty <- tcExpr p e > ty <- tcExpr p e
> checkSkolems p (text "Expression:" <+> ppExpr 0 expr) tyEnv0 > checkSkolems p (text "Expression:" <+> ppExpr 0 expr) tyEnv0
> (foldr TypeArrow ty tys) > (foldr TypeArrow ty tys)
> tcExpr p (Let ds e) = do > tcExpr p (Let ds e) = do
> tyEnv0 <- getValueEnv > tyEnv0 <- getValueEnv
> tcDecls ds > tcDecls ds
> ty <- tcExpr p e > ty <- tcExpr p e
> checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty > checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty
> tcExpr p (Do sts e) = do > tcExpr p (Do sts e) = do
> tyEnv0 <- getValueEnv > tyEnv0 <- getValueEnv
> mapM_ (tcStmt p) sts > mapM_ (tcStmt p) sts
> alpha <- freshTypeVar > alpha <- freshTypeVar
> ty <- tcExpr p e > ty <- tcExpr p e
> unify p "statement" (ppExpr 0 e) (ioType alpha) ty > unify p "statement" (ppExpr 0 e) (ioType alpha) ty
> checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty > checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty
> tcExpr p e@(IfThenElse _ e1 e2 e3) = do > tcExpr p e@(IfThenElse _ e1 e2 e3) = do
> ty1 <- tcExpr p e1 > ty1 <- tcExpr p e1
> unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) > unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
> boolType ty1 > boolType ty1
> ty2 <- tcExpr p e2 > ty2 <- tcExpr p e2
> ty3 <- tcExpr p e3 > ty3 <- tcExpr p e3
> unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3) > unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3)
> ty2 ty3 > ty2 ty3
> return ty3 > return ty3
> tcExpr p (Case _ _ e alts) = do > tcExpr p (Case _ _ e alts) = do
> tyEnv0 <- getValueEnv > tyEnv0 <- getValueEnv
> ty <- tcExpr p e > ty <- tcExpr p e
> alpha <- freshTypeVar > alpha <- freshTypeVar
> tcAlts tyEnv0 ty alpha alts > tcAlts tyEnv0 ty alpha alts
> where tcAlts _ _ ty [] = return ty > where tcAlts _ _ ty [] = return ty
> tcAlts tyEnv0 ty1 ty2 (alt1:alts1) = > tcAlts tyEnv0 ty1 ty2 (alt1:alts1) =
> tcAlt (ppAlt alt1) tyEnv0 ty1 ty2 alt1 >> tcAlts tyEnv0 ty1 ty2 alts1 > tcAlt (ppAlt alt1) tyEnv0 ty1 ty2 alt1 >> tcAlts tyEnv0 ty1 ty2 alts1
...@@ -943,31 +935,22 @@ because of possibly multiple occurrences of variables. ...@@ -943,31 +935,22 @@ because of possibly multiple occurrences of variables.
> tcRhs tyEnv0 rhs >>= > tcRhs tyEnv0 rhs >>=
> unify p1 "case branch" doc ty2 > unify p1 "case branch" doc ty2
> tcExpr _ (RecordConstr fs) = do > tcExpr _ (RecordConstr fs) = do
> fts <- mapM tcFieldExpr fs > fts <- mapM tcFieldExpr fs
> return (TypeRecord fts Nothing) > return (TypeRecord fts Nothing)
> tcExpr p r@(RecordSelection e l) = do > tcExpr p r@(RecordSelection e l) = do
> m <- getModuleIdent > lty <- instLabel l
> ty <- tcExpr p e > ety <- tcExpr p e
> tyEnv <- getValueEnv > alpha <- freshVar id
> lty <- maybe (freshTypeVar > let rty = TypeRecord [(l, lty)] (Just alpha)
> >>= (\lty' -> > unify p "record selection" (ppExpr 0 r) ety rty
> modifyValueEnv > return lty
> (bindLabel l (qualifyWith m (mkIdent "#Rec"))
> (monoType lty'))
> >> return lty'))
> (\ (ForAll _ lty') -> return lty')
> (sureLabelType l tyEnv)
> alpha <- freshVar id
> let rty = TypeRecord [(l,lty)] (Just alpha)
> unify p "record selection" (ppExpr 0 r) ty rty
> return lty
> tcExpr p r@(RecordUpdate fs e) = do > tcExpr p r@(RecordUpdate fs e) = do
> ty <- tcExpr p e > ty <- tcExpr p e
> fts <- mapM tcFieldExpr fs > fts <- mapM tcFieldExpr fs
> alpha <- freshVar id > alpha <- freshVar id
> let rty = TypeRecord fts (Just alpha) > let rty = TypeRecord fts (Just alpha)
> unify p "record update" (ppExpr 0 r) ty rty > unify p "record update" (ppExpr 0 r) ty rty
> return ty > return ty
> tcQual :: Position -> Statement -> TCM () > tcQual :: Position -> Statement -> TCM ()
> tcQual p (StmtExpr _ e) = > tcQual p (StmtExpr _ e) =
...@@ -991,20 +974,11 @@ because of possibly multiple occurrences of variables. ...@@ -991,20 +974,11 @@ because of possibly multiple occurrences of variables.
> tcStmt _ (StmtDecl ds) = tcDecls ds > tcStmt _ (StmtDecl ds) = tcDecls ds
> tcFieldExpr :: Field Expression -> TCM (Ident, Type) > tcFieldExpr :: Field Expression -> TCM (Ident, Type)
> tcFieldExpr f@(Field _ l e) = do > tcFieldExpr f@(Field p l e) = do
> m <- getModuleIdent > lty <- instLabel l
> tyEnv <- getValueEnv > ety <- tcExpr p e
> let p = idPosition l > unify p "record" (text "Field:" <+> ppFieldExpr f) lty ety
> lty <- maybe (freshTypeVar > return (l, ety)
> >>= (\lty' ->
> modifyValueEnv (bindLabel l (qualifyWith m (mkIdent "#Rec"))
> (monoType lty'))
> >> return lty'))
> inst
> (sureLabelType l tyEnv)
> ty <- tcExpr p e
> unify p "record" (text "Field:" <+> ppFieldExpr f) lty ty
> return (l,ty)
\end{verbatim} \end{verbatim}
The function \texttt{tcArrow} checks that its argument can be used as The function \texttt{tcArrow} checks that its argument can be used as
...@@ -1190,6 +1164,16 @@ We use negative offsets for fresh type variables. ...@@ -1190,6 +1164,16 @@ We use negative offsets for fresh type variables.
> tys <- replicateM (n + n') freshTypeVar > tys <- replicateM (n + n') freshTypeVar
> return $ expandAliasType tys ty > return $ expandAliasType tys ty
> instLabel :: Ident -> TCM Type
> instLabel l = do
> m <- getModuleIdent
> tyEnv <- getValueEnv
> maybe (freshTypeVar >>= \lty' -> modifyValueEnv
> (bindLabel l (qualifyWith m (mkIdent "#Rec")) (monoType lty'))
> >> return lty')
> inst
> (sureLabelType l tyEnv)
> skol :: ExistTypeScheme -> TCM Type > skol :: ExistTypeScheme -> TCM Type
> skol (ForAllExist n n' ty) = do > skol (ForAllExist n n' ty) = do
> tys <- replicateM n freshTypeVar > tys <- replicateM n freshTypeVar
...@@ -1398,8 +1382,8 @@ Error functions. ...@@ -1398,8 +1382,8 @@ Error functions.
> errIncompatibleLabelTypes :: ModuleIdent -> Ident -> Type -> Type -> Doc > errIncompatibleLabelTypes :: ModuleIdent -> Ident -> Type -> Type -> Doc
> errIncompatibleLabelTypes m l ty1 ty2 = sep > errIncompatibleLabelTypes m l ty1 ty2 = sep
> [ text "Labeled types" <+> ppIdent l <> text "::" <> ppType m ty1 > [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1
> , nest 10 $ text "and" <+> ppIdent l <> text "::" <> ppType m ty2 > , nest 10 $ text "and" <+> ppIdent l <+> text "::" <+> ppType m ty2
> , text "are incompatible" > , text "are incompatible"
> ] > ]
......
I don't know if it's really a bug or I only don't understand records well.
The following gives a compiling error:
> fun :: a -> Bool
> fun _ = True
> fun3 :: a -> a -> Bool
> fun3 _ _ = False
> type Rec a = { a :: a, b :: Bool }
> testRecSel1 = { a := 'c', b := True } :> a
> testRecSel2 x y = { a := fun x, b := fun3 y y } :> a
The type of the record used in testRecSel1 somehow propagates
to the type of the record used in testRecSel2.
If one comments the definition of testRecSel1 then there is no error.
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