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

Checks improved

parent 6bef7507
......@@ -13,8 +13,9 @@
-}
module Checks where
import Curry.Base.MessageMonad (Message)
import Curry.Syntax
import Curry.Syntax (Module (..))
import Base.Messages
import qualified Checks.KindCheck as KC (kindCheck)
import qualified Checks.PrecCheck as PC (precCheck)
......@@ -25,36 +26,51 @@ import qualified Checks.WarnCheck as WC (warnCheck)
import CompilerEnv
import CompilerOpts
data CheckStatus a
= CheckFailed [Message]
| CheckSuccess a
instance Monad CheckStatus where
return = CheckSuccess
m >>= f = case m of
CheckFailed errs -> CheckFailed errs
CheckSuccess a -> f a
-- TODO: More documentation
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
kindCheck (Module m es is ds) env = (Module m es is ds', env)
where ds' = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
kindCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
kindCheck env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
precCheck (Module m es is ds) env = (Module m es is ds', env { opPrecEnv = pEnv' })
where (pEnv', ds') = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
precCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
precCheck env (Module m es is ds)
| null msgs = (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the syntax check.
syntaxCheck :: Options -> Module -> CompilerEnv -> (Module, CompilerEnv)
syntaxCheck opts (Module m es is ds) env = (Module m es is ds', env)
where ds' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env)
syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
syntaxCheck opts env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) ds
withExt = BerndExtension `elem` optExtensions opts
-- |Apply the type check.
typeCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
typeCheck mdl@(Module _ _ _ ds) env = (mdl, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
typeCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds) = (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) ds
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck :: Module -> CompilerEnv -> [Message]
warnCheck (Module _ _ is ds) env
warnCheck :: CompilerEnv -> Module -> [Message]
warnCheck env (Module _ _ is ds)
= WC.warnCheck (moduleIdent env) (valueEnv env) is ds
......@@ -4,6 +4,7 @@
% See LICENSE for the full license.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
% Modified by Björn Peemöller (bjp@informatik.uni-kiel.de)
%
\nwfilename{KindCheck.lhs}
\section{Checking Type Definitions}
......@@ -14,7 +15,7 @@ type classes, kind checking is rather trivial. All types must be of
first order kind ($\star$), i.e., all type constructor applications
must be saturated.
During kind checking, this module will also disambiguate nullary
During kind checking, this module will also disambiguate nullary type
constructors and type variables which -- in contrast to Haskell -- is
not possible on purely syntactic criteria. In addition it is checked
that all type constructors and type variables occurring on the right
......@@ -24,17 +25,17 @@ is defined more than once.
> module Checks.KindCheck (kindCheck) where
> import Control.Monad.State
> import Control.Monad (forM, liftM, liftM2, liftM3, when)
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Base.MessageMonad (Message (..), showError)
> import Curry.Syntax
> import Base.Messages (errorAt', internalError)
> import Base.Utils (findDouble)
> import Base.Messages (Message, posErr, qposErr, internalError)
> import Base.TopEnv
> import Base.Utils (findMultiples)
> import Env.TopEnv
> import Env.TypeConstructors (TCEnv, tcArity)
\end{verbatim}
......@@ -47,32 +48,37 @@ defined type constructors are inserted into the environment, and,
finally, the declarations are checked within this environment.
\begin{verbatim}
TODO: Propagate errors
> kindCheck :: ModuleIdent -> TCEnv -> [Decl] -> ([Decl], [Message])
> kindCheck m tcEnv decls = case findMultiples $ map typeConstr tds of
> [] -> runKCM (mapM checkDecl decls) initState
> ms -> (decls, map errMultipleDeclaration ms)
> where tds = filter isTypeDecl decls
> kEnv = foldr (bindKind m) (fmap tcArity tcEnv) tds
> initState = KCState m kEnv []
> kindCheck :: ModuleIdent -> TCEnv -> [Decl] -> [Decl]
> kindCheck m tcEnv decls = case findDouble $ map typeConstr typeDecls of
> Just tc -> errorAt' $ errDuplicateType tc
> Nothing -> case errors s' of
> [] -> decls'
> errs -> errorAt' $ last errs
> where typeDecls = filter isTypeDecl decls
> kEnv = foldr (bindKind m) (fmap tcArity tcEnv) typeDecls
> initState = CheckState m kEnv []
> (decls',s') = runKcM (mapM checkDecl decls) initState
\end{verbatim}
The kind check monad.
\begin{verbatim}
> data CheckState = CheckState
> data KCState = KCState
> { moduleIdent :: ModuleIdent
> , kindEnv :: KindEnv
> , errors :: [(Position, String)]
> , errors :: [Message]
> }
> type KcM = State CheckState
> type KCM = S.State KCState -- the Kind Check Monad
> runKCM :: KCM a -> KCState -> (a, [Message])
> runKCM kcm s = let (a, s') = S.runState kcm s in (a, reverse $ errors s')
> getModuleIdent :: KCM ModuleIdent
> getModuleIdent = S.gets moduleIdent
> runKcM :: KcM a -> CheckState -> (a, CheckState)
> runKcM = runState
> getKindEnv :: KCM KindEnv
> getKindEnv = S.gets kindEnv
> reportError :: (Position, String) -> KcM ()
> reportError err = modify (\ s -> s { errors = err : errors s })
> report :: Message -> KCM ()
> report err = S.modify (\ s -> s { errors = err : errors s })
\end{verbatim}
The kind environment only needs to record the arity of each type constructor.
......@@ -87,10 +93,10 @@ The kind environment only needs to record the arity of each type constructor.
> bindKind _ _ = id
> bindKind' :: ModuleIdent -> Ident -> [Ident] -> KindEnv -> KindEnv
> bindKind' m tc tvs = bindTopEnv "KindCheck.bindKind'" tc n
> . qualBindTopEnv "KindCheck.bindKind'" qtc n
> where n = length tvs
> qtc = qualifyWith m tc
> bindKind' m tc tvs = bindTopEnv "KindCheck.bindKind'" tc arity
> . qualBindTopEnv "KindCheck.bindKind'" qtc arity
> where arity = length tvs
> qtc = qualifyWith m tc
> lookupKind :: Ident -> KindEnv -> [Int]
> lookupKind = lookupTopEnv
......@@ -105,7 +111,7 @@ the right hand side. Function and pattern declarations must be
traversed because they can contain local type signatures.
\begin{verbatim}
> checkDecl :: Decl -> KcM Decl
> checkDecl :: Decl -> KCM Decl
> checkDecl (DataDecl p tc tvs cs) = do
> tvs' <- checkTypeLhs tvs
> cs' <- mapM (checkConstrDecl tvs') cs
......@@ -118,21 +124,17 @@ traversed because they can contain local type signatures.
> tvs' <- checkTypeLhs tvs
> ty' <- checkClosedType tvs' ty
> return $ TypeDecl p tc tvs' ty'
> checkDecl (TypeSig p vs ty) = do
> ty' <- checkType ty
> return $ TypeSig p vs ty'
> checkDecl (FunctionDecl p f eqs) = do
> eqs' <- mapM checkEquation eqs
> return $ FunctionDecl p f eqs'
> checkDecl (PatternDecl p t rhs) = do
> rhs' <- checkRhs rhs
> return $ PatternDecl p t rhs'
> checkDecl (ExternalDecl p cc ie f ty) = do
> ty' <- checkType ty
> return $ ExternalDecl p cc ie f ty'
> checkDecl (TypeSig p vs ty) =
> TypeSig p vs `liftM` checkType ty
> checkDecl (FunctionDecl p f eqs) =
> FunctionDecl p f `liftM` mapM checkEquation eqs
> checkDecl (PatternDecl p t rhs) =
> PatternDecl p t `liftM` checkRhs rhs
> checkDecl (ExternalDecl p cc ie f ty) =
> ExternalDecl p cc ie f `liftM` checkType ty
> checkDecl d = return d
> checkConstrDecl :: [Ident] -> ConstrDecl -> KcM ConstrDecl
> checkConstrDecl :: [Ident] -> ConstrDecl -> KCM ConstrDecl
> checkConstrDecl tvs (ConstrDecl p evs c tys) = do
> evs' <- checkTypeLhs evs
> tys' <- mapM (checkClosedType (evs' ++ tvs)) tys
......@@ -144,7 +146,7 @@ traversed because they can contain local type signatures.
> ty2' <- checkClosedType tvs' ty2
> return $ ConOpDecl p evs' ty1' op ty2'
> checkNewConstrDecl :: [Ident] -> NewConstrDecl -> KcM NewConstrDecl
> checkNewConstrDecl :: [Ident] -> NewConstrDecl -> KCM NewConstrDecl
> checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
> evs' <- checkTypeLhs evs
> ty' <- checkClosedType (evs' ++ tvs) ty
......@@ -154,15 +156,14 @@ traversed because they can contain local type signatures.
> -- * Anonymous type variables are allowed
> -- * only type variables (no type constructors)
> -- * linearity
> checkTypeLhs :: [Ident] -> KcM [Ident]
> checkTypeLhs :: [Ident] -> KCM [Ident]
> checkTypeLhs [] = return []
> checkTypeLhs (tv : tvs) = do
> when (tv /= anonId) $ do
> isTyCons <- gets (not . null . lookupKind tv . kindEnv)
> when isTyCons $ reportError $ errNoVariable tv
> when (tv `elem` tvs) $ reportError $ errNonLinear tv
> tvs' <- checkTypeLhs tvs
> return $ tv : tvs'
> isTyCons <- (not . null . lookupKind tv) `liftM` getKindEnv
> when isTyCons $ report $ errNoVariable tv
> when (tv `elem` tvs) $ report $ errNonLinear tv
> (tv :) `liftM` checkTypeLhs tvs
\end{verbatim}
Checking expressions is rather straight forward. The compiler must
......@@ -170,132 +171,68 @@ only traverse the structure of expressions in order to find local
declaration groups.
\begin{verbatim}
> checkEquation :: Equation -> KcM Equation
> checkEquation (Equation p lhs rhs) = do
> rhs' <- checkRhs rhs
> return $ Equation p lhs rhs'
> checkRhs :: Rhs -> KcM Rhs
> checkRhs (SimpleRhs p e ds) = do
> e' <- checkExpr e
> ds' <- mapM checkDecl ds
> return $ SimpleRhs p e' ds'
> checkRhs (GuardedRhs es ds) = do
> es' <- mapM checkCondExpr es
> ds' <- mapM checkDecl ds
> return $ GuardedRhs es' ds'
> checkCondExpr :: CondExpr -> KcM CondExpr
> checkCondExpr (CondExpr p g e) = do
> g' <- checkExpr g
> e' <- checkExpr e
> return $ CondExpr p g' e'
> checkExpr :: Expression -> KcM Expression
> checkExpr (Literal l) = return $ Literal l
> checkExpr (Variable v) = return $ Variable v
> checkExpr (Constructor c) = return $ Constructor c
> checkExpr (Paren e) = do
> e' <- checkExpr e
> return $ Paren e'
> checkExpr (Typed e ty) = do
> e' <- checkExpr e
> ty' <- checkType ty
> return $ Typed e' ty'
> checkExpr (Tuple p es) = do
> es' <- mapM checkExpr es
> return $ Tuple p es'
> checkExpr (List p es) = do
> es' <- mapM checkExpr es
> return $ List p es'
> checkExpr (ListCompr p e qs) = do
> e' <- checkExpr e
> qs' <- mapM checkStmt qs
> return $ ListCompr p e' qs'
> checkExpr (EnumFrom e) = do
> e' <- checkExpr e
> return $ EnumFrom e'
> checkExpr (EnumFromThen e1 e2) = do
> e1' <- checkExpr e1
> e2' <- checkExpr e2
> return $ EnumFromThen e1' e2'
> checkExpr (EnumFromTo e1 e2) = do
> e1' <- checkExpr e1
> e2' <- checkExpr e2
> return $ EnumFromTo e1' e2'
> checkExpr (EnumFromThenTo e1 e2 e3) = do
> e1' <- checkExpr e1
> e2' <- checkExpr e2
> e3' <- checkExpr e3
> return $ EnumFromThenTo e1' e2' e3'
> checkExpr (UnaryMinus op e) = do
> e' <- checkExpr e
> return $ UnaryMinus op e'
> checkExpr (Apply e1 e2) = do
> e1' <- checkExpr e1
> e2' <- checkExpr e2
> return $ Apply e1' e2'
> checkExpr (InfixApply e1 op e2) = do
> e1' <- checkExpr e1
> e2' <- checkExpr e2
> return $ InfixApply e1' op e2'
> checkExpr (LeftSection e op) = do
> e' <- checkExpr e
> return $ LeftSection e' op
> checkExpr (RightSection op e) = do
> e' <- checkExpr e
> return $ RightSection op e'
> checkExpr (Lambda r ts e) = do
> e' <- checkExpr e
> return $ Lambda r ts e'
> checkExpr (Let ds e) = do
> ds' <- mapM checkDecl ds
> e' <- checkExpr e
> return $ Let ds' e'
> checkExpr (Do sts e) = do
> sts' <- mapM checkStmt sts
> e' <- checkExpr e
> return $ Do sts' e'
> checkExpr (IfThenElse r e1 e2 e3) = do
> e1' <- checkExpr e1
> e2' <- checkExpr e2
> e3' <- checkExpr e3
> return $ IfThenElse r e1' e2' e3'
> checkExpr (Case r e alts) = do
> e' <- checkExpr e
> alts' <- mapM checkAlt alts
> return $ Case r e' alts'
> checkExpr (RecordConstr fs) = do
> fs' <- mapM checkFieldExpr fs
> return $ RecordConstr fs'
> checkExpr (RecordSelection e l) = do
> e' <- checkExpr e
> return $ RecordSelection e' l
> checkExpr (RecordUpdate fs e) = do
> fs' <- mapM checkFieldExpr fs
> e' <- checkExpr e
> return $ RecordUpdate fs' e'
> checkStmt :: Statement -> KcM Statement
> checkStmt (StmtExpr p e) = do
> e' <- checkExpr e
> return $ StmtExpr p e'
> checkStmt (StmtBind p t e) = do
> e' <- checkExpr e
> return $ StmtBind p t e'
> checkStmt (StmtDecl ds) = do
> ds' <- mapM checkDecl ds
> return $ StmtDecl ds'
> checkAlt :: Alt -> KcM Alt
> checkAlt (Alt p t rhs) = do
> rhs' <- checkRhs rhs
> return $ Alt p t rhs'
> checkFieldExpr :: Field Expression -> KcM (Field Expression)
> checkFieldExpr (Field p l e) = do
> e' <- checkExpr e
> return $ Field p l e'
> checkEquation :: Equation -> KCM Equation
> checkEquation (Equation p lhs rhs) = Equation p lhs `liftM` checkRhs rhs
> checkRhs :: Rhs -> KCM Rhs
> checkRhs (SimpleRhs p e ds) =
> liftM2 (SimpleRhs p) (checkExpr e) (mapM checkDecl ds)
> checkRhs (GuardedRhs es ds) =
> liftM2 GuardedRhs (mapM checkCondExpr es) (mapM checkDecl ds)
> checkCondExpr :: CondExpr -> KCM CondExpr
> checkCondExpr (CondExpr p g e) =
> liftM2 (CondExpr p) (checkExpr g) (checkExpr e)
> checkExpr :: Expression -> KCM Expression
> checkExpr l@(Literal _) = return l
> checkExpr v@(Variable _) = return v
> checkExpr c@(Constructor _) = return c
> checkExpr (Paren e) = Paren `liftM` checkExpr e
> checkExpr (Typed e ty) = liftM2 Typed (checkExpr e) (checkType ty)
> checkExpr (Tuple p es) = Tuple p `liftM` mapM checkExpr es
> checkExpr (List p es) = List p `liftM` mapM checkExpr es
> checkExpr (ListCompr p e qs) =
> liftM2 (ListCompr p) (checkExpr e) (mapM checkStmt qs)
> checkExpr (EnumFrom e) = EnumFrom `liftM` checkExpr e
> checkExpr (EnumFromThen e1 e2) =
> liftM2 EnumFromThen (checkExpr e1) (checkExpr e2)
> checkExpr (EnumFromTo e1 e2) =
> liftM2 EnumFromTo (checkExpr e1) (checkExpr e2)
> checkExpr (EnumFromThenTo e1 e2 e3) =
> liftM3 EnumFromThenTo (checkExpr e1) (checkExpr e2) (checkExpr e3)
> checkExpr (UnaryMinus op e) = UnaryMinus op `liftM` checkExpr e
> checkExpr (Apply e1 e2) = liftM2 Apply (checkExpr e1) (checkExpr e2)
> checkExpr (InfixApply e1 op e2) =
> liftM2 (\f1 f2 -> InfixApply f1 op f2) (checkExpr e1) (checkExpr e2)
> checkExpr (LeftSection e op) = flip LeftSection op `liftM` checkExpr e
> checkExpr (RightSection op e) = RightSection op `liftM` checkExpr e
> checkExpr (Lambda r ts e) = Lambda r ts `liftM` checkExpr e
> checkExpr (Let ds e) =
> liftM2 Let (mapM checkDecl ds) (checkExpr e)
> checkExpr (Do sts e) =
> liftM2 Do (mapM checkStmt sts) (checkExpr e)
> checkExpr (IfThenElse r e1 e2 e3) =
> liftM3 (IfThenElse r) (checkExpr e1) (checkExpr e2) (checkExpr e3)
> checkExpr (Case r e alts) =
> liftM2 (Case r) (checkExpr e) (mapM checkAlt alts)
> checkExpr (RecordConstr fs) =
> RecordConstr `liftM` mapM checkFieldExpr fs
> checkExpr (RecordSelection e l) =
> flip RecordSelection l `liftM` checkExpr e
> checkExpr (RecordUpdate fs e) =
> liftM2 RecordUpdate (mapM checkFieldExpr fs) (checkExpr e)
> checkStmt :: Statement -> KCM Statement
> checkStmt (StmtExpr p e) = StmtExpr p `liftM` checkExpr e
> checkStmt (StmtBind p t e) = StmtBind p t `liftM` checkExpr e
> checkStmt (StmtDecl ds) = StmtDecl `liftM` mapM checkDecl ds
> checkAlt :: Alt -> KCM Alt
> checkAlt (Alt p t rhs) = Alt p t `liftM` checkRhs rhs
> checkFieldExpr :: Field Expression -> KCM (Field Expression)
> checkFieldExpr (Field p l e) = Field p l `liftM` checkExpr e
\end{verbatim}
The parser cannot distinguish unqualified nullary type constructors
......@@ -304,69 +241,59 @@ identifier in a position where a type variable is admissible, it will
interpret the identifier as such.
\begin{verbatim}
> checkClosedType :: [Ident] -> TypeExpr -> KcM TypeExpr
> checkClosedType :: [Ident] -> TypeExpr -> KCM TypeExpr
> checkClosedType tvs ty = checkType ty >>= checkClosed tvs
> checkType :: TypeExpr -> KcM TypeExpr
> checkType :: TypeExpr -> KCM TypeExpr
> checkType c@(ConstructorType tc tys) = do
> m <- gets moduleIdent
> kEnv <- gets kindEnv
> m <- getModuleIdent
> kEnv <- getKindEnv
> case qualLookupKind tc kEnv of
> []
> | not (isQualified tc) && null tys -> return $ VariableType $ unqualify tc
> | otherwise -> reportError (errUndefinedType tc) >> return c
> | not (isQualified tc) && null tys ->
> return $ VariableType $ unqualify tc
> | otherwise -> report (errUndefinedType tc) >> return c
> [n]
> | n == n' -> do
> tys' <- mapM checkType tys
> return $ ConstructorType tc tys'
> | otherwise -> reportError (errWrongArity tc n n') >> return c
> | n == n' -> ConstructorType tc `liftM` mapM checkType tys
> | otherwise -> report (errWrongArity tc n n') >> return c
> _ -> case qualLookupKind (qualQualify m tc) kEnv of
> [n]
> | n == n' -> do
> tys' <- mapM checkType tys
> return $ ConstructorType tc tys'
> | otherwise -> reportError (errWrongArity tc n n') >> return c
> _ -> reportError (errAmbiguousType tc) >> return c
> [n]
> | n == n' -> ConstructorType tc `liftM` mapM checkType tys
> | otherwise -> report (errWrongArity tc n n') >> return c
> _ -> report (errAmbiguousType tc) >> return c
> where n' = length tys
> checkType (VariableType tv)
> | tv == anonId = return $ VariableType tv
> | otherwise = checkType (ConstructorType (qualify tv) [])
> checkType (TupleType tys) = do
> tys' <- mapM checkType tys
> return $ TupleType tys'
> checkType (ListType ty) = do
> ty' <- checkType ty
> return $ ListType ty'
> checkType (ArrowType ty1 ty2) = do
> ty1' <- checkType ty1
> ty2' <- checkType ty2
> return $ ArrowType ty1' ty2'
> checkType (RecordType fs r) = do
> fs' <- mapM (\ (l, ty) -> do { ty' <- checkType ty; return (l, ty') }) fs
> checkType v@(VariableType tv)
> | tv == anonId = return v
> | otherwise = checkType $ ConstructorType (qualify tv) []
> checkType (TupleType tys) = TupleType `liftM` mapM checkType tys
> checkType (ListType ty) = ListType `liftM` checkType ty
> checkType (ArrowType ty1 ty2) =
> liftM2 ArrowType (checkType ty1) (checkType ty2)
> checkType (RecordType fs r) = do
> fs' <- forM fs $ \ (l, ty) -> do
> ty' <- checkType ty
> return (l, ty')
> r' <- case r of
> Nothing -> return Nothing
> Just ar -> Just `liftM` checkType ar
> return $ RecordType fs' r'
> checkClosed :: [Ident] -> TypeExpr -> KcM TypeExpr
> checkClosed tvs (ConstructorType tc tys) = do
> tys' <- mapM (checkClosed tvs) tys
> return $ ConstructorType tc tys'
> checkClosed tvs (VariableType tv) = do
> when (tv == anonId || tv `notElem` tvs) $ reportError $ errUnboundVariable tv
> return $ VariableType tv
> checkClosed tvs (TupleType tys) = do
> tys' <- mapM (checkClosed tvs) tys
> return $ TupleType $ tys'
> checkClosed tvs (ListType ty) = do
> ty' <- checkClosed tvs ty
> return $ ListType ty'
> checkClosed tvs (ArrowType ty1 ty2) = do
> ty1' <- checkClosed tvs ty1
> ty2' <- checkClosed tvs ty2
> return $ ArrowType ty1' ty2'
> checkClosed :: [Ident] -> TypeExpr -> KCM TypeExpr
> checkClosed tvs (ConstructorType tc tys) =
> ConstructorType tc `liftM` mapM (checkClosed tvs) tys
> checkClosed tvs v@(VariableType tv) = do
> when (tv == anonId || tv `notElem` tvs) $ report $ errUnboundVariable tv
> return v
> checkClosed tvs (TupleType tys) =
> TupleType `liftM` mapM (checkClosed tvs) tys
> checkClosed tvs (ListType ty) =
> ListType `liftM` checkClosed tvs ty
> checkClosed tvs (ArrowType ty1 ty2) =
> liftM2 ArrowType (checkClosed tvs ty1) (checkClosed tvs ty2)
> checkClosed tvs (RecordType fs r) = do
> fs' <- mapM (\ (l, ty) -> do { ty' <- checkClosed tvs ty; return (l, ty') }) fs
> fs' <- forM fs $ \ (l, ty) -> do
> ty' <- checkClosed tvs ty
> return (l, ty')
> r' <- case r of
> Nothing -> return Nothing
> Just ar -> Just `liftM` checkClosed tvs ar
......@@ -386,25 +313,29 @@ Auxiliary definitions
Error messages:
\begin{verbatim}
> errUndefinedType :: QualIdent -> (Position, String)
> errUndefinedType :: QualIdent -> Message
> errUndefinedType tc = qposErr tc $ "Undefined type " ++ qualName tc
> errAmbiguousType :: QualIdent -> (Position, String)
> errAmbiguousType :: QualIdent -> Message
> errAmbiguousType tc = qposErr tc $ "Ambiguous type " ++ qualName tc
> errDuplicateType :: Ident -> (Position, String)
> errDuplicateType tc = posErr tc
> $ "More than one definition for type " ++ name tc
> errMultipleDeclaration :: [Ident] -> Message
> errMultipleDeclaration [] = internalError
> "KindCheck.errMultipleDeclaration: empty list"
> errMultipleDeclaration (i:is) = posErr i $
> "Multiple declarations for type `" ++ name i ++ "` at:\n"
> ++ unlines (map showPos (i:is))
> where showPos = (" " ++) . showLine . positionOfIdent
> errNonLinear :: Ident -> (Position, String)
> errNonLinear :: Ident -> Message
> errNonLinear tv = posErr tv $ "Type variable " ++ name tv ++