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

Internal errors improved, KindCheck improved

parent 84eccf2a
......@@ -44,7 +44,7 @@ order of type variables in the left hand side of a type declaration.
> toType' tvs (CS.ConstructorType tc tys) =
> TypeConstructor tc (map (toType' tvs) tys)
> toType' tvs (CS.VariableType tv) =
> maybe (internalError $ "toType " ++ show tv) TypeVariable (Map.lookup tv tvs)
> maybe (internalError $ "Base.CurryTypes.toType': " ++ show tv) TypeVariable (Map.lookup tv tvs)
> toType' tvs (CS.TupleType tys)
> | null tys = TypeConstructor (qualify unitId) []
> | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys'
......@@ -57,7 +57,7 @@ order of type variables in the left hand side of a type declaration.
> (maybe Nothing
> (\ ty -> case toType' tvs ty of
> TypeVariable tv -> Just tv
> _ -> internalError ("toType " ++ show ty))
> _ -> internalError ("Base.CurryTypes.toType' " ++ show ty))
> rty)
> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
......
......@@ -330,7 +330,7 @@ checker.
> S.modify (bindVar tv (TypeArrow ty1 ty2))
> return (ty1,ty2)
> TypeArrow ty1 ty2 -> return (ty1,ty2)
> ty' -> internalError ("unifyArrow (" ++ show ty' ++ ")")
> ty' -> internalError ("Base.Typing.unifyArrow (" ++ show ty' ++ ")")
> unifyArrow2 :: Type -> TyState (Type,Type,Type)
> unifyArrow2 ty =
......@@ -367,7 +367,7 @@ checker.
> (TypeVariable a2)
> (foldr (unifyTypedLabels fs1) theta fs2)
> unifyTypes ty1 ty2 _ =
> internalError ("unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")")
> internalError ("Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")")
> unifyTypedLabels :: [(Ident,Type)] -> (Ident,Type) -> TypeSubst -> TypeSubst
> unifyTypedLabels fs1 (l,ty) theta =
......@@ -382,28 +382,24 @@ pattern variables, and variables.
\begin{verbatim}
> constrType :: QualIdent -> ValueEnv -> ExistTypeScheme
> constrType c tyEnv =
> case qualLookupValue c tyEnv of
> constrType c tyEnv = case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError ("constrType " ++ show c)
> _ -> internalError $ "Base.Typing.constrType: " ++ show c
> varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv =
> case lookupValue v tyEnv of
> varType v tyEnv = case lookupValue v tyEnv of
> [Value _ sigma] -> sigma
> _ -> internalError ("varType " ++ show v)
> _ -> internalError $ "Base.Typing.varType: " ++ show v
> funType :: QualIdent -> ValueEnv -> TypeScheme
> funType f tyEnv =
> case qualLookupValue f tyEnv of
> funType f tyEnv = case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma
> _ -> internalError ("funType " ++ show f)
> _ -> internalError $ "Base.Typing.funType: " ++ show f
> labelType :: Ident -> ValueEnv -> TypeScheme
> labelType l tyEnv =
> case lookupValue l tyEnv of
> labelType l tyEnv = case lookupValue l tyEnv of
> [Label _ _ sigma] -> sigma
> _ -> internalError ("labelType " ++ show l)
> _ -> internalError $ "Base.Typing.labelType: " ++ show l
\end{verbatim}
......@@ -29,31 +29,32 @@ import CompilerOpts
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
kindCheck decls env = (decls', env)
where decls' = KC.kindCheck (moduleIdent env) (tyConsEnv env) decls
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
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
precCheck decls env = (decls', env { opPrecEnv = pEnv' })
where (pEnv', decls') = PC.precCheck (moduleIdent env) (opPrecEnv env) decls
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
-- |Apply the syntax check.
syntaxCheck :: Options -> [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
syntaxCheck opts decls env = (decls', env)
where decls' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) decls
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)
(arityEnv env) (valueEnv env) (tyConsEnv env) ds
withExt = BerndExtension `elem` optExtensions opts
-- |Apply the type check.
typeCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
typeCheck decls env = (decls, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
typeCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
typeCheck mdl@(Module _ _ _ ds) env = (mdl, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) decls
(tyConsEnv env) (valueEnv env) ds
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck :: CompilerEnv -> [ImportDecl] -> [Decl] -> [Message]
warnCheck env = WC.warnCheck (moduleIdent env) (valueEnv env)
warnCheck :: Module -> CompilerEnv -> [Message]
warnCheck (Module _ _ is ds) env
= WC.warnCheck (moduleIdent env) (valueEnv env) is ds
......@@ -24,8 +24,11 @@ is defined more than once.
> module Checks.KindCheck (kindCheck) where
> import Control.Monad.State
> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.Base.MessageMonad (Message (..), showError)
> import Curry.Syntax
> import Base.Messages (errorAt', internalError)
......@@ -44,13 +47,32 @@ 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]
> kindCheck m tcEnv ds =
> case findDouble (map tconstr ds') of
> Nothing -> map (checkDecl m kEnv) ds
> Just tc -> errorAt' (duplicateType tc)
> where ds' = filter isTypeDecl ds
> kEnv = foldr (bindArity m) (fmap tcArity tcEnv) ds'
> 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
> data CheckState = CheckState
> { moduleIdent :: ModuleIdent
> , kindEnv :: KindEnv
> , errors :: [(Position, String)]
> }
> type KcM = State CheckState
> runKcM :: KcM a -> CheckState -> (a, CheckState)
> runKcM = runState
> reportError :: (Position, String) -> KcM ()
> reportError err = modify (\ s -> s { errors = err : errors s })
\end{verbatim}
The kind environment only needs to record the arity of each type constructor.
......@@ -58,18 +80,17 @@ The kind environment only needs to record the arity of each type constructor.
> type KindEnv = TopEnv Int
> bindArity :: ModuleIdent -> Decl -> KindEnv -> KindEnv
> bindArity m (DataDecl _ tc tvs _) = bindArity' m tc tvs
> bindArity m (NewtypeDecl _ tc tvs _) = bindArity' m tc tvs
> bindArity m (TypeDecl _ tc tvs _) = bindArity' m tc tvs
> bindArity _ _ = id
> bindKind :: ModuleIdent -> Decl -> KindEnv -> KindEnv
> bindKind m (DataDecl _ tc tvs _) = bindKind' m tc tvs
> bindKind m (NewtypeDecl _ tc tvs _) = bindKind' m tc tvs
> bindKind m (TypeDecl _ tc tvs _) = bindKind' m tc tvs
> bindKind _ _ = id
> bindArity' :: ModuleIdent -> Ident -> [Ident]
> -> KindEnv -> KindEnv
> bindArity' m tc tvs
> = bindTopEnv "KindCheck.bindArity'" tc n
> . qualBindTopEnv "KindCheck.bindArity'" (qualifyWith m tc) n
> where n = length tvs
> 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
> lookupKind :: Ident -> KindEnv -> [Int]
> lookupKind = lookupTopEnv
......@@ -84,52 +105,64 @@ the right hand side. Function and pattern declarations must be
traversed because they can contain local type signatures.
\begin{verbatim}
> checkDecl :: ModuleIdent -> KindEnv -> Decl -> Decl
> checkDecl m kEnv (DataDecl p tc tvs cs) =
> DataDecl p tc tvs' (map (checkConstrDecl m kEnv tvs') cs)
> where tvs' = checkTypeLhs kEnv tvs
> checkDecl m kEnv (NewtypeDecl p tc tvs nc) =
> NewtypeDecl p tc tvs' (checkNewConstrDecl m kEnv tvs' nc)
> where tvs' = checkTypeLhs kEnv tvs
> checkDecl m kEnv (TypeDecl p tc tvs ty) =
> TypeDecl p tc tvs' (checkClosedType m kEnv tvs' ty)
> where tvs' = checkTypeLhs kEnv tvs
> checkDecl m kEnv (TypeSig p vs ty) =
> TypeSig p vs (checkType m kEnv ty)
> checkDecl m kEnv (FunctionDecl p f eqs) =
> FunctionDecl p f (map (checkEquation m kEnv) eqs)
> checkDecl m kEnv (PatternDecl p t rhs) =
> PatternDecl p t (checkRhs m kEnv rhs)
> checkDecl m kEnv (ExternalDecl p cc ie f ty) =
> ExternalDecl p cc ie f (checkType m kEnv ty)
> checkDecl _ _ d = d
> checkTypeLhs :: KindEnv -> [Ident] -> [Ident]
> checkTypeLhs kEnv (tv:tvs)
> | tv == anonId = tv : checkTypeLhs kEnv tvs
> | isTypeConstr tv = errorAt' (noVariable tv)
> | tv `elem` tvs = errorAt' (nonLinear tv)
> | otherwise = tv : checkTypeLhs kEnv tvs
> where isTypeConstr tv' = not (null (lookupKind tv' kEnv))
> checkTypeLhs _ [] = []
> checkConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> ConstrDecl -> ConstrDecl
> checkConstrDecl m kEnv tvs (ConstrDecl p evs c tys) =
> ConstrDecl p evs' c (map (checkClosedType m kEnv tvs') tys)
> where evs' = checkTypeLhs kEnv evs
> tvs' = evs' ++ tvs
> checkConstrDecl m kEnv tvs (ConOpDecl p evs ty1 op ty2) =
> ConOpDecl p evs' (checkClosedType m kEnv tvs' ty1) op
> (checkClosedType m kEnv tvs' ty2)
> where evs' = checkTypeLhs kEnv evs
> tvs' = evs' ++ tvs
> checkNewConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> NewConstrDecl
> -> NewConstrDecl
> checkNewConstrDecl m kEnv tvs (NewConstrDecl p evs c ty) =
> NewConstrDecl p evs' c (checkClosedType m kEnv tvs' ty)
> where evs' = checkTypeLhs kEnv evs
> tvs' = evs' ++ tvs
> checkDecl :: Decl -> KcM Decl
> checkDecl (DataDecl p tc tvs cs) = do
> tvs' <- checkTypeLhs tvs
> cs' <- mapM (checkConstrDecl tvs') cs
> return $ DataDecl p tc tvs' cs'
> checkDecl (NewtypeDecl p tc tvs nc) = do
> tvs' <- checkTypeLhs tvs
> nc' <- checkNewConstrDecl tvs' nc
> return $ NewtypeDecl p tc tvs' nc'
> checkDecl (TypeDecl p tc tvs ty) = do
> 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 d = return d
> checkConstrDecl :: [Ident] -> ConstrDecl -> KcM ConstrDecl
> checkConstrDecl tvs (ConstrDecl p evs c tys) = do
> evs' <- checkTypeLhs evs
> tys' <- mapM (checkClosedType (evs' ++ tvs)) tys
> return $ ConstrDecl p evs' c tys'
> checkConstrDecl tvs (ConOpDecl p evs ty1 op ty2) = do
> evs' <- checkTypeLhs evs
> let tvs' = evs' ++ tvs
> ty1' <- checkClosedType tvs' ty1
> ty2' <- checkClosedType tvs' ty2
> return $ ConOpDecl p evs' ty1' op ty2'
> checkNewConstrDecl :: [Ident] -> NewConstrDecl -> KcM NewConstrDecl
> checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
> evs' <- checkTypeLhs evs
> ty' <- checkClosedType (evs' ++ tvs) ty
> return $ NewConstrDecl p evs' c ty'
> -- |Check the left-hand-side of a type declaration for
> -- * Anonymous type variables are allowed
> -- * only type variables (no type constructors)
> -- * linearity
> 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'
\end{verbatim}
Checking expressions is rather straight forward. The compiler must
......@@ -137,74 +170,132 @@ only traverse the structure of expressions in order to find local
declaration groups.
\begin{verbatim}
> checkEquation :: ModuleIdent -> KindEnv -> Equation -> Equation
> checkEquation m kEnv (Equation p lhs rhs) =
> Equation p lhs (checkRhs m kEnv rhs)
> checkRhs :: ModuleIdent -> KindEnv -> Rhs -> Rhs
> checkRhs m kEnv (SimpleRhs p e ds) =
> SimpleRhs p (checkExpr m kEnv e) (map (checkDecl m kEnv) ds)
> checkRhs m kEnv (GuardedRhs es ds) =
> GuardedRhs (map (checkCondExpr m kEnv) es) (map (checkDecl m kEnv) ds)
> checkCondExpr :: ModuleIdent -> KindEnv -> CondExpr -> CondExpr
> checkCondExpr m kEnv (CondExpr p g e) =
> CondExpr p (checkExpr m kEnv g) (checkExpr m kEnv e)
> checkExpr :: ModuleIdent -> KindEnv -> Expression -> Expression
> checkExpr _ _ (Literal l) = Literal l
> checkExpr _ _ (Variable v) = Variable v
> checkExpr _ _ (Constructor c) = Constructor c
> checkExpr m kEnv (Paren e) = Paren (checkExpr m kEnv e)
> checkExpr m kEnv (Typed e ty) =
> Typed (checkExpr m kEnv e) (checkType m kEnv ty)
> checkExpr m kEnv (Tuple p es) = Tuple p (map (checkExpr m kEnv ) es)
> checkExpr m kEnv (List p es) = List p (map (checkExpr m kEnv ) es)
> checkExpr m kEnv (ListCompr p e qs) =
> ListCompr p (checkExpr m kEnv e) (map (checkStmt m kEnv ) qs)
> checkExpr m kEnv (EnumFrom e) = EnumFrom (checkExpr m kEnv e)
> checkExpr m kEnv (EnumFromThen e1 e2) =
> EnumFromThen (checkExpr m kEnv e1) (checkExpr m kEnv e2)
> checkExpr m kEnv (EnumFromTo e1 e2) =
> EnumFromTo (checkExpr m kEnv e1) (checkExpr m kEnv e2)
> checkExpr m kEnv (EnumFromThenTo e1 e2 e3) =
> EnumFromThenTo (checkExpr m kEnv e1) (checkExpr m kEnv e2)
> (checkExpr m kEnv e3)
> checkExpr m kEnv (UnaryMinus op e) = UnaryMinus op (checkExpr m kEnv e)
> checkExpr m kEnv (Apply e1 e2) =
> Apply (checkExpr m kEnv e1) (checkExpr m kEnv e2)
> checkExpr m kEnv (InfixApply e1 op e2) =
> InfixApply (checkExpr m kEnv e1) op (checkExpr m kEnv e2)
> checkExpr m kEnv (LeftSection e op) = LeftSection (checkExpr m kEnv e) op
> checkExpr m kEnv (RightSection op e) = RightSection op (checkExpr m kEnv e)
> checkExpr m kEnv (Lambda r ts e) = Lambda r ts (checkExpr m kEnv e)
> checkExpr m kEnv (Let ds e) =
> Let (map (checkDecl m kEnv) ds) (checkExpr m kEnv e)
> checkExpr m kEnv (Do sts e) =
> Do (map (checkStmt m kEnv ) sts) (checkExpr m kEnv e)
> checkExpr m kEnv (IfThenElse r e1 e2 e3) =
> IfThenElse r (checkExpr m kEnv e1) (checkExpr m kEnv e2)
> (checkExpr m kEnv e3)
> checkExpr m kEnv (Case r e alts) =
> Case r (checkExpr m kEnv e) (map (checkAlt m kEnv) alts)
> checkExpr m kEnv (RecordConstr fs) =
> RecordConstr (map (checkFieldExpr m kEnv) fs)
> checkExpr m kEnv (RecordSelection e l) =
> RecordSelection (checkExpr m kEnv e) l
> checkExpr m kEnv (RecordUpdate fs e) =
> RecordUpdate (map (checkFieldExpr m kEnv) fs) (checkExpr m kEnv e)
> checkStmt :: ModuleIdent -> KindEnv -> Statement -> Statement
> checkStmt m kEnv (StmtExpr p e) = StmtExpr p (checkExpr m kEnv e)
> checkStmt m kEnv (StmtBind p t e) = StmtBind p t (checkExpr m kEnv e)
> checkStmt m kEnv (StmtDecl ds) = StmtDecl (map (checkDecl m kEnv) ds)
> checkAlt :: ModuleIdent -> KindEnv -> Alt -> Alt
> checkAlt m kEnv (Alt p t rhs) = Alt p t (checkRhs m kEnv rhs)
> checkFieldExpr :: ModuleIdent -> KindEnv -> Field Expression
> -> Field Expression
> checkFieldExpr m kEnv (Field p l e) = Field p l (checkExpr m kEnv e)
> 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'
\end{verbatim}
The parser cannot distinguish unqualified nullary type constructors
......@@ -213,108 +304,121 @@ identifier in a position where a type variable is admissible, it will
interpret the identifier as such.
\begin{verbatim}
> checkClosedType :: ModuleIdent -> KindEnv -> [Ident] -> TypeExpr
> -> TypeExpr
> checkClosedType m kEnv tvs ty = checkClosed tvs (checkType m kEnv ty)
> checkClosedType :: [Ident] -> TypeExpr -> KcM TypeExpr
> checkClosedType tvs ty = checkType ty >>= checkClosed tvs
> checkType :: ModuleIdent -> KindEnv -> TypeExpr -> TypeExpr
> checkType m kEnv (ConstructorType tc tys) =
> checkType :: TypeExpr -> KcM TypeExpr
> checkType c@(ConstructorType tc tys) = do
> m <- gets moduleIdent
> kEnv <- gets kindEnv
> case qualLookupKind tc kEnv of
> []
> | not (isQualified tc) && null tys -> VariableType (unqualify tc)
> | otherwise -> errorAt' (undefinedType tc)
> | not (isQualified tc) && null tys -> return $ VariableType $ unqualify tc
> | otherwise -> reportError (errUndefinedType tc) >> return c
> [n]
> | n == n' -> ConstructorType tc (map (checkType m kEnv ) tys)
> | otherwise -> errorAt' (wrongArity tc n n')
> _ -> case (qualLookupKind (qualQualify m tc) kEnv) of
> [n]
> | n == n' -> ConstructorType tc (map (checkType m kEnv ) tys)
> | otherwise -> errorAt' (wrongArity tc n n')
> _ -> errorAt' (ambiguousType tc)
> | n == n' -> do
> tys' <- mapM checkType tys
> return $ ConstructorType tc tys'
> | otherwise -> reportError (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
> where n' = length tys
> checkType m kEnv (VariableType tv)
> | tv == anonId = VariableType tv
> | otherwise = checkType m kEnv (ConstructorType (qualify tv) [])
> checkType m kEnv (TupleType tys) =
> TupleType (map (checkType m kEnv ) tys)
> checkType m kEnv (ListType ty) =
> ListType (checkType m kEnv ty)
> checkType m kEnv (ArrowType ty1 ty2) =
> ArrowType (checkType m kEnv ty1) (checkType m kEnv ty2)
> checkType m kEnv (RecordType fs r) =
> RecordType (map (\ (ls,ty) -> (ls, checkType m kEnv ty)) fs)
> (maybe Nothing (Just . checkType m kEnv ) r)
> checkClosed :: [Ident] -> TypeExpr -> TypeExpr
> checkClosed tvs (ConstructorType tc tys) =
> ConstructorType tc (map (checkClosed tvs) tys)
> checkClosed tvs (VariableType tv)
> | tv == anonId || tv `notElem` tvs = errorAt' (unboundVariable tv)
> | otherwise = VariableType tv
> checkClosed tvs (TupleType tys) =