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

Fixed bug when checking type signatures

parent fea6f764
......@@ -31,6 +31,8 @@ type annotation is present.
> import qualified Data.Set as Set (Set, fromList, member, notMember, unions)
> import Text.PrettyPrint
> import Debug.Trace
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Syntax
......@@ -375,9 +377,9 @@ either one of the basic types or \texttt{()}.
> where (vds, ods) = partition isValueDecl ds
> tcDeclGroup :: [Decl] -> TCM ()
> tcDeclGroup [ForeignDecl _ _ _ f ty] = tcExternal f ty
> tcDeclGroup [ExternalDecl _ fs] = mapM_ tcFlatExternal fs
> tcDeclGroup [FreeDecl _ vs] = mapM_ tcExtraVar vs
> tcDeclGroup [ForeignDecl _ _ _ f ty] = tcForeign f ty
> tcDeclGroup [ExternalDecl _ fs] = mapM_ tcExternal fs
> tcDeclGroup [FreeDecl _ vs] = mapM_ tcFree vs
> tcDeclGroup ds = do
> tyEnv0 <- getValueEnv
> tysLhs <- mapM tcDeclLhs ds
......@@ -386,11 +388,11 @@ either one of the basic types or \texttt{()}.
> theta <- getTypeSubst
> mapM_ (genDecl (fvEnv (subst theta tyEnv0)) theta) ds
> --tcDeclGroup m tcEnv _ [ForeignDecl p cc _ f ty] =
> -- tcForeignFunct m tcEnv p cc f ty
> -- tcForeign m tcEnv p cc f ty
> --tcForeignFunct :: ModuleIdent -> TCEnv -> Position -> CallConv -> Ident
> --tcForeign :: ModuleIdent -> TCEnv -> Position -> CallConv -> Ident
> -- -> TypeExpr -> TCM ()
> --tcForeignFunct m tcEnv p cc f ty =
> --tcForeign m tcEnv p cc f ty =
> -- S.modify (bindFun m f (checkForeignType cc (expandPolyType tcEnv ty)))
> -- where checkForeignType CallConvPrimitive ty = ty
> -- checkForeignType CallConvCCall (ForAll n ty) =
......@@ -409,40 +411,46 @@ either one of the basic types or \texttt{()}.
> -- isCResultType _ = False
> -- basicTypeId = [qBoolId,qCharId,qIntId,qFloatId]
> tcExternal :: Ident -> TypeExpr -> TCM ()
> tcExternal f ty = do
> tcForeign :: Ident -> TypeExpr -> TCM ()
> tcForeign f ty = do
> m <- getModuleIdent
> tySc@(ForAll _ ty') <- expandPolyType ty
> modifyValueEnv $ bindFun m f (arrowArity ty') tySc
> tcFlatExternal :: Ident -> TCM ()
> tcFlatExternal f = do
> tcExternal :: Ident -> TCM ()
> tcExternal f = do
> sigs <- getSigEnv
> case lookupTypeSig f sigs of
> Nothing -> internalError "TypeCheck.tcFlatExternal"
> Just ty -> do
> m <- getModuleIdent
> tySc@(ForAll _ ty') <- expandPolyType ty
> modifyValueEnv $ bindFun m f (arrowArity ty') tySc
> Nothing -> internalError "TypeCheck.tcExternal"
> Just ty -> tcForeign f ty
> tcExtraVar :: Ident -> TCM ()
> tcExtraVar v = do
> tcFree :: Ident -> TCM ()
> tcFree v = do
> sigs <- getSigEnv
> m <- getModuleIdent
> case lookupTypeSig v sigs of
> Nothing -> do
> ty <- freshTypeVar
> modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty
> Just ty -> do
> ForAll n ty' <- expandPolyType ty
> ty <- case lookupTypeSig v sigs of
> Nothing -> freshTypeVar
> Just t -> do
> ForAll n ty' <- expandPolyType t
> unless (n == 0) $ report $ errPolymorphicFreeVar v
> modifyValueEnv $ bindFun m v (arrowArity ty') $ monoType ty'
> return ty'
> modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty
> tcDeclLhs :: Decl -> TCM Type
> tcDeclLhs (FunctionDecl p f _) = tcPattern p (VariablePattern f)
> tcDeclLhs (FunctionDecl _ f _) = tcFunDecl f
> tcDeclLhs (PatternDecl p t _) = tcPattern p t
> tcDeclLhs _ = internalError "TypeCheck.tcDeclLhs: no pattern match"
> tcFunDecl :: Ident -> TCM Type
> tcFunDecl v = do
> sigs <- getSigEnv
> m <- getModuleIdent
> ty <- case lookupTypeSig v sigs of
> Nothing -> freshTypeVar
> Just t -> expandPolyType t >>= inst
> modifyValueEnv $ bindFun m v (arrowArity ty) (monoType ty)
> return ty
> tcDeclRhs :: ValueEnv -> Decl -> TCM Type
> tcDeclRhs tyEnv0 (FunctionDecl _ f (eq:eqs)) = do
> tcEquation tyEnv0 eq >>= flip tcEqns eqs
......@@ -504,7 +512,8 @@ signature the declared type must be too general.
> Nothing -> modifyValueEnv $ rebindFun m v arity sigma
> Just sigTy -> do
> sigma' <- expandPolyType sigTy
> unless (eqTyScheme sigma sigma') $ report $ errTypeSigTooGeneral (idPosition v) m what sigTy sigma
> unless (eqTyScheme sigma sigma') $ report
> $ errTypeSigTooGeneral (idPosition v) m what sigTy sigma
> modifyValueEnv $ rebindFun m v arity sigma
> where
> what = text (if poly then "Function:" else "Variable:") <+> ppIdent v
......@@ -537,11 +546,11 @@ signature the declared type must be too general.
> tcPattern _ (NegativePattern _ l) = tcLiteral l
> tcPattern _ (VariablePattern v) = do
> sigs <- getSigEnv
> m <- getModuleIdent
> ty <- case lookupTypeSig v sigs of
> Nothing -> freshTypeVar
> Just t -> expandPolyType t >>= inst
> tyEnv <- getValueEnv
> m <- getModuleIdent
> maybe (modifyValueEnv (bindFun m v (arrowArity ty) (monoType ty)) >> return ty)
> (\ (ForAll _ t) -> return t)
> (sureVarType v tyEnv)
......@@ -1244,7 +1253,6 @@ unambiguously refers to the local definition.
> Label _ _ sigma : _ -> Just sigma
> _ -> Nothing
\end{verbatim}
The function \texttt{expandType} expands all type synonyms in a type
and also qualifies all type constructors with the name of the module
......
Supports Markdown
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