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.
> import qualified Data.Map as Map (Map, empty, insert, lookup)
> import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, listToMaybe, maybeToList)
> import qualified Data.Set as Set (Set, fromList, member, notMember, unions)
> import Text.PrettyPrint
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Base.Pretty
> import Curry.Syntax
> import Curry.Syntax.Pretty
......@@ -623,16 +623,14 @@ signature the declared type must be too general.
> tcPattern p (FunctionPattern op [t1,t2])
> tcPattern p r@(RecordPattern fs rt)
> | isJust rt = do
> m <- getModuleIdent
> ty <- tcPattern p (fromJust rt)
> fts <- mapM (tcFieldPatt tcPattern m) fs
> fts <- mapM (tcFieldPatt tcPattern) fs
> alpha <- freshVar id
> let rty = TypeRecord fts (Just alpha)
> unify p "record pattern" (ppPattern 0 r) ty rty
> return rty
> | otherwise = do
> m <- getModuleIdent
> fts <- mapM (tcFieldPatt tcPattern m) fs
> fts <- mapM (tcFieldPatt tcPattern) fs
> return (TypeRecord fts Nothing)
\end{verbatim}
......@@ -720,34 +718,31 @@ because of possibly multiple occurrences of variables.
> tcPatternFP p (FunctionPattern op [t1,t2])
> tcPatternFP p r@(RecordPattern fs rt)
> | isJust rt = do
> m <- getModuleIdent
> ty <- tcPatternFP p (fromJust rt)
> fts <- mapM (tcFieldPatt tcPatternFP m) fs
> fts <- mapM (tcFieldPatt tcPatternFP) fs
> alpha <- freshVar id
> let rty = TypeRecord fts (Just alpha)
> unify p "record pattern" (ppPattern 0 r) ty rty
> return rty
> | otherwise = do
> m <- getModuleIdent
> fts <- mapM (tcFieldPatt tcPatternFP m) fs
> fts <- mapM (tcFieldPatt tcPatternFP) fs
> return (TypeRecord fts Nothing)
> tcFieldPatt :: (Position -> Pattern -> TCM Type) -> ModuleIdent
> -> Field Pattern -> TCM (Ident, Type)
> tcFieldPatt tcPatt m f@(Field _ l t) = do
> tcFieldPatt :: (Position -> Pattern -> TCM Type) -> Field Pattern
> -> TCM (Ident, Type)
> tcFieldPatt tcPatt f@(Field _ l t) = do
> m <- getModuleIdent
> tyEnv <- getValueEnv
> let p = idPosition l
> lty <- maybe (freshTypeVar
> >>= (\lty' ->
> lty <- maybe (freshTypeVar >>= \lty' ->
> modifyValueEnv
> (bindLabel l (qualifyWith m (mkIdent "#Rec"))
> (polyType lty'))
> >> return lty'))
> (\ (ForAll _ lty') -> return lty')
> (bindLabel l (qualifyWith m (mkIdent "#Rec")) (polyType lty'))
> >> return lty')
> inst
> (sureLabelType l tyEnv)
> ty <- tcPatt p t
> unify p "record" (text "Field:" <+> ppFieldPatt f) lty ty
> return (l,ty)
> return (l, ty)
> tcRhs ::ValueEnv -> Rhs -> TCM Type
> tcRhs tyEnv0 (SimpleRhs p e ds) = do
......@@ -761,24 +756,20 @@ because of possibly multiple occurrences of variables.
> tcCondExprs :: ValueEnv -> [CondExpr] -> TCM Type
> tcCondExprs tyEnv0 es = do
> gty <- if length es > 1 then return boolType
> else freshConstrained [successType,boolType]
> else freshConstrained [successType, boolType]
> ty <- freshTypeVar
> tcCondExprs' gty ty es
> where tcCondExprs' _ ty [] = return ty
> tcCondExprs' gty ty (e1:es1) =
> tcCondExpr gty ty e1 >> tcCondExprs' gty ty es1
> mapM_ (tcCondExpr gty ty) es
> return ty
> where
> tcCondExpr gty ty (CondExpr p g e) = do
> tcExpr p g >>=
> unify p "guard" (ppExpr 0 g) gty >>
> tcExpr p e >>=
> checkSkolems p (text "Expression:" <+> ppExpr 0 e) tyEnv0 >>=
> unify p "guarded expression" (ppExpr 0 e) ty
> tcExpr p g >>= unify p "guard" (ppExpr 0 g) gty
> 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 _ (Literal l) = tcLiteral l
> tcExpr _ (Variable v)
> -- anonymous free variable
> | isAnonId v' = do
> | isAnonId v' = do -- anonymous free variable
> m <- getModuleIdent
> ty <- freshTypeVar
> modifyValueEnv $ bindFun m v' (arrowArity ty) $ monoType ty
......@@ -801,7 +792,8 @@ because of possibly multiple occurrences of variables.
> inst sigma' >>= flip (unify p "explicitly typed expression" (ppExpr 0 e)) ty
> theta <- getTypeSubst
> 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
> where sig' = nameSigType sig
> tcExpr p (Paren e) = tcExpr p e
......@@ -946,20 +938,11 @@ because of possibly multiple occurrences of variables.
> fts <- mapM tcFieldExpr fs
> return (TypeRecord fts Nothing)
> tcExpr p r@(RecordSelection e l) = do
> m <- getModuleIdent
> ty <- tcExpr p e
> tyEnv <- getValueEnv
> lty <- maybe (freshTypeVar
> >>= (\lty' ->
> modifyValueEnv
> (bindLabel l (qualifyWith m (mkIdent "#Rec"))
> (monoType lty'))
> >> return lty'))
> (\ (ForAll _ lty') -> return lty')
> (sureLabelType l tyEnv)
> lty <- instLabel l
> ety <- tcExpr p e
> alpha <- freshVar id
> let rty = TypeRecord [(l,lty)] (Just alpha)
> unify p "record selection" (ppExpr 0 r) ty rty
> let rty = TypeRecord [(l, lty)] (Just alpha)
> unify p "record selection" (ppExpr 0 r) ety rty
> return lty
> tcExpr p r@(RecordUpdate fs e) = do
> ty <- tcExpr p e
......@@ -991,20 +974,11 @@ because of possibly multiple occurrences of variables.
> tcStmt _ (StmtDecl ds) = tcDecls ds
> tcFieldExpr :: Field Expression -> TCM (Ident, Type)
> tcFieldExpr f@(Field _ l e) = do
> m <- getModuleIdent
> tyEnv <- getValueEnv
> let p = idPosition l
> lty <- maybe (freshTypeVar
> >>= (\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)
> tcFieldExpr f@(Field p l e) = do
> lty <- instLabel l
> ety <- tcExpr p e
> unify p "record" (text "Field:" <+> ppFieldExpr f) lty ety
> return (l, ety)
\end{verbatim}
The function \texttt{tcArrow} checks that its argument can be used as
......@@ -1190,6 +1164,16 @@ We use negative offsets for fresh type variables.
> tys <- replicateM (n + n') freshTypeVar
> 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 (ForAllExist n n' ty) = do
> tys <- replicateM n freshTypeVar
......@@ -1398,8 +1382,8 @@ Error functions.
> errIncompatibleLabelTypes :: ModuleIdent -> Ident -> Type -> Type -> Doc
> errIncompatibleLabelTypes m l ty1 ty2 = sep
> [ text "Labeled types" <+> ppIdent l <> text "::" <> ppType m ty1
> , nest 10 $ text "and" <+> ppIdent l <> text "::" <> ppType m ty2
> [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1
> , nest 10 $ text "and" <+> ppIdent l <+> text "::" <+> ppType m ty2
> , 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