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. ...@@ -44,7 +44,7 @@ order of type variables in the left hand side of a type declaration.
> toType' tvs (CS.ConstructorType tc tys) = > toType' tvs (CS.ConstructorType tc tys) =
> TypeConstructor tc (map (toType' tvs) tys) > TypeConstructor tc (map (toType' tvs) tys)
> toType' tvs (CS.VariableType tv) = > 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) > toType' tvs (CS.TupleType tys)
> | null tys = TypeConstructor (qualify unitId) [] > | null tys = TypeConstructor (qualify unitId) []
> | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys' > | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys'
...@@ -57,7 +57,7 @@ order of type variables in the left hand side of a type declaration. ...@@ -57,7 +57,7 @@ order of type variables in the left hand side of a type declaration.
> (maybe Nothing > (maybe Nothing
> (\ ty -> case toType' tvs ty of > (\ ty -> case toType' tvs ty of
> TypeVariable tv -> Just tv > TypeVariable tv -> Just tv
> _ -> internalError ("toType " ++ show ty)) > _ -> internalError ("Base.CurryTypes.toType' " ++ show ty))
> rty) > rty)
> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr > fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
......
...@@ -330,7 +330,7 @@ checker. ...@@ -330,7 +330,7 @@ checker.
> S.modify (bindVar tv (TypeArrow ty1 ty2)) > S.modify (bindVar tv (TypeArrow ty1 ty2))
> return (ty1,ty2) > return (ty1,ty2)
> 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 :: Type -> TyState (Type,Type,Type)
> unifyArrow2 ty = > unifyArrow2 ty =
...@@ -367,7 +367,7 @@ checker. ...@@ -367,7 +367,7 @@ checker.
> (TypeVariable a2) > (TypeVariable a2)
> (foldr (unifyTypedLabels fs1) theta fs2) > (foldr (unifyTypedLabels fs1) theta fs2)
> unifyTypes ty1 ty2 _ = > 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 :: [(Ident,Type)] -> (Ident,Type) -> TypeSubst -> TypeSubst
> unifyTypedLabels fs1 (l,ty) theta = > unifyTypedLabels fs1 (l,ty) theta =
...@@ -382,28 +382,24 @@ pattern variables, and variables. ...@@ -382,28 +382,24 @@ pattern variables, and variables.
\begin{verbatim} \begin{verbatim}
> constrType :: QualIdent -> ValueEnv -> ExistTypeScheme > constrType :: QualIdent -> ValueEnv -> ExistTypeScheme
> constrType c tyEnv = > constrType c tyEnv = case qualLookupValue c tyEnv of
> case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma > [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma > [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError ("constrType " ++ show c) > _ -> internalError $ "Base.Typing.constrType: " ++ show c
> varType :: Ident -> ValueEnv -> TypeScheme > varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv = > varType v tyEnv = case lookupValue v tyEnv of
> case lookupValue v tyEnv of
> [Value _ sigma] -> sigma > [Value _ sigma] -> sigma
> _ -> internalError ("varType " ++ show v) > _ -> internalError $ "Base.Typing.varType: " ++ show v
> funType :: QualIdent -> ValueEnv -> TypeScheme > funType :: QualIdent -> ValueEnv -> TypeScheme
> funType f tyEnv = > funType f tyEnv = case qualLookupValue f tyEnv of
> case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma > [Value _ sigma] -> sigma
> _ -> internalError ("funType " ++ show f) > _ -> internalError $ "Base.Typing.funType: " ++ show f
> labelType :: Ident -> ValueEnv -> TypeScheme > labelType :: Ident -> ValueEnv -> TypeScheme
> labelType l tyEnv = > labelType l tyEnv = case lookupValue l tyEnv of
> case lookupValue l tyEnv of
> [Label _ _ sigma] -> sigma > [Label _ _ sigma] -> sigma
> _ -> internalError ("labelType " ++ show l) > _ -> internalError $ "Base.Typing.labelType: " ++ show l
\end{verbatim} \end{verbatim}
...@@ -29,31 +29,32 @@ import CompilerOpts ...@@ -29,31 +29,32 @@ import CompilerOpts
-- |Check the kinds of type definitions and signatures. -- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished -- In addition, nullary type constructors and type variables are dinstiguished
kindCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv) kindCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
kindCheck decls env = (decls', env) kindCheck (Module m es is ds) env = (Module m es is ds', env)
where decls' = KC.kindCheck (moduleIdent env) (tyConsEnv env) decls where ds' = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Apply the precendences of infix operators. -- |Apply the precendences of infix operators.
-- This function reanrranges the AST. -- This function reanrranges the AST.
precCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv) precCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
precCheck decls env = (decls', env { opPrecEnv = pEnv' }) precCheck (Module m es is ds) env = (Module m es is ds', env { opPrecEnv = pEnv' })
where (pEnv', decls') = PC.precCheck (moduleIdent env) (opPrecEnv env) decls where (pEnv', ds') = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the syntax check. -- |Apply the syntax check.
syntaxCheck :: Options -> [Decl] -> CompilerEnv -> ([Decl], CompilerEnv) syntaxCheck :: Options -> Module -> CompilerEnv -> (Module, CompilerEnv)
syntaxCheck opts decls env = (decls', env) syntaxCheck opts (Module m es is ds) env = (Module m es is ds', env)
where decls' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env) where ds' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) decls (arityEnv env) (valueEnv env) (tyConsEnv env) ds
withExt = BerndExtension `elem` optExtensions opts withExt = BerndExtension `elem` optExtensions opts
-- |Apply the type check. -- |Apply the type check.
typeCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv) typeCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
typeCheck decls env = (decls, env { tyConsEnv = tcEnv', valueEnv = tyEnv' }) typeCheck mdl@(Module _ _ _ ds) env = (mdl, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env) where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) decls (tyConsEnv env) (valueEnv env) ds
-- TODO: Which kind of warnings? -- TODO: Which kind of warnings?
-- |Check for warnings. -- |Check for warnings.
warnCheck :: CompilerEnv -> [ImportDecl] -> [Decl] -> [Message] warnCheck :: Module -> CompilerEnv -> [Message]
warnCheck env = WC.warnCheck (moduleIdent env) (valueEnv env) warnCheck (Module _ _ is ds) env
= WC.warnCheck (moduleIdent env) (valueEnv env) is ds
This diff is collapsed.
...@@ -38,13 +38,11 @@ imported precedence environment. ...@@ -38,13 +38,11 @@ imported precedence environment.
\begin{verbatim} \begin{verbatim}
> bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv > bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv
> bindPrecs m ds pEnv = > bindPrecs m ds pEnv = case findDouble ops of
> case findDouble ops of > Nothing -> case [ op | op <- ops, op `notElem` bvs] of
> Nothing -> > [] -> foldr bindPrec pEnv fixDs
> case [ op | op <- ops, op `notElem` bvs] of > op : _ -> errorAt' (undefinedOperator op)
> [] -> foldr bindPrec pEnv fixDs > Just op -> errorAt' (duplicatePrecedence op)
> op : _ -> errorAt' (undefinedOperator op)
> Just op -> errorAt' (duplicatePrecedence op)
> where (fixDs,nonFixDs) = partition isInfixDecl ds > where (fixDs,nonFixDs) = partition isInfixDecl ds
> bvs = concatMap boundValues nonFixDs > bvs = concatMap boundValues nonFixDs
> ops = [ op | InfixDecl _ _ _ ops' <- fixDs, op <- ops'] > ops = [ op | InfixDecl _ _ _ ops' <- fixDs, op <- ops']
...@@ -56,8 +54,8 @@ imported precedence environment. ...@@ -56,8 +54,8 @@ imported precedence environment.
> boundValues :: Decl -> [Ident] > boundValues :: Decl -> [Ident]
> boundValues (DataDecl _ _ _ cs) = map constr cs > boundValues (DataDecl _ _ _ cs) = map constr cs
> where constr (ConstrDecl _ _ c _) = c > where constr (ConstrDecl _ _ c _) = c
> constr (ConOpDecl _ _ _ op _) = op > constr (ConOpDecl _ _ _ op _) = op
> boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c] > boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
> boundValues (FunctionDecl _ f _) = [f] > boundValues (FunctionDecl _ f _) = [f]
> boundValues (ExternalDecl _ _ _ f _) = [f] > boundValues (ExternalDecl _ _ _ f _) = [f]
...@@ -77,13 +75,13 @@ be returned because it is needed for constructing the module's ...@@ -77,13 +75,13 @@ be returned because it is needed for constructing the module's
interface. interface.
\begin{verbatim} \begin{verbatim}
> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl]) > precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv, [Decl])
> precCheck = checkDecls > precCheck = checkDecls
> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl]) > checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv, [Decl])
> checkDecls m pEnv ds = pEnv' `seq` (pEnv',ds') > checkDecls m pEnv ds = pEnv' `seq` (pEnv', ds')
> where pEnv' = bindPrecs m ds pEnv > where pEnv' = bindPrecs m ds pEnv
> ds' = map (checkDecl m pEnv') ds > ds' = map (checkDecl m pEnv') ds
> checkDecl :: ModuleIdent -> PEnv -> Decl -> Decl > checkDecl :: ModuleIdent -> PEnv -> Decl -> Decl
> checkDecl m pEnv (FunctionDecl p f eqs) = > checkDecl m pEnv (FunctionDecl p f eqs) =
...@@ -430,10 +428,9 @@ an operator definition that shadows an imported definition. ...@@ -430,10 +428,9 @@ an operator definition that shadows an imported definition.
> opPrec op = prec (opName op) > opPrec op = prec (opName op)
> prec :: QualIdent -> PEnv -> OpPrec > prec :: QualIdent -> PEnv -> OpPrec
> prec op env = > prec op env = case qualLookupP op env of
> case qualLookupP op env of > [] -> defaultP
> [] -> defaultP > PrecInfo _ p : _ -> p
> PrecInfo _ p : _ -> p
\end{verbatim} \end{verbatim}
Error messages. Error messages.
......
...@@ -127,12 +127,12 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}. ...@@ -127,12 +127,12 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
> [ArityInfo _ arity'] -> GlobalVar arity' qid > [ArityInfo _ arity'] -> GlobalVar arity' qid
> rs -> case qualLookupArity qid' aEnv of > rs -> case qualLookupArity qid' aEnv of
> [ArityInfo _ arity''] -> GlobalVar arity'' qid > [ArityInfo _ arity''] -> GlobalVar arity'' qid
> _ -> maybe (internalError $ "renameInfo: missing arity for " ++ show qid) > _ -> maybe (internalError $ "SyntaxCheck.renameInfo: missing arity for " ++ show qid)
> (\ (ArityInfo _ arity'') -> GlobalVar arity'' qid) > (\ (ArityInfo _ arity'') -> GlobalVar arity'' qid)
> (find (\ (ArityInfo qid'' _) -> qid'' == qid) rs) > (find (\ (ArityInfo qid'' _) -> qid'' == qid) rs)
> renameInfo tcEnv _ _ (Label _ r _) = case (qualLookupTC r tcEnv) of > renameInfo tcEnv _ _ (Label _ r _) = case (qualLookupTC r tcEnv) of
> [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r (map fst fs) > [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r (map fst fs)
> _ -> internalError "renameInfo: no record" > _ -> internalError "SyntaxCheck.renameInfo: no record"
\end{verbatim} \end{verbatim}
Since record types are currently translated into data types, it is Since record types are currently translated into data types, it is
...@@ -178,7 +178,7 @@ than once. ...@@ -178,7 +178,7 @@ than once.
> bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv > bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
> bindFuncDecl m (FunctionDecl _ ident equs) env > bindFuncDecl m (FunctionDecl _ ident equs) env
> | null equs = internalError "bindFuncDecl: missing equations" > | null equs = internalError "SyntaxCheck.bindFuncDecl: missing equations"
> | otherwise = let (_,ts) = getFlatLhs (head equs) > | otherwise = let (_,ts) = getFlatLhs (head equs)
> in bindGlobal m > in bindGlobal m
> ident > ident
...@@ -199,7 +199,7 @@ than once. ...@@ -199,7 +199,7 @@ than once.
> bindVarDecl :: Decl -> RenameEnv -> RenameEnv > bindVarDecl :: Decl -> RenameEnv -> RenameEnv
> bindVarDecl (FunctionDecl _ ident equs) env > bindVarDecl (FunctionDecl _ ident equs) env
> | null equs > | null equs
> = internalError "bindFuncDecl: missing equations" > = internalError "SyntaxCheck.bindFuncDecl: missing equations"
> | otherwise > | otherwise
> = let (_,ts) = getFlatLhs (head equs) > = let (_,ts) = getFlatLhs (head equs)
> in bindLocal (unRenameIdent ident) (LocalVar (length ts) ident) env > in bindLocal (unRenameIdent ident) (LocalVar (length ts) ident) env
...@@ -260,7 +260,7 @@ local declarations. ...@@ -260,7 +260,7 @@ local declarations.
> checkTypeDecl :: Bool -> ModuleIdent -> Decl -> Decl > checkTypeDecl :: Bool -> ModuleIdent -> Decl -> Decl
> checkTypeDecl withExt _ (TypeDecl p r tvs (RecordType fs rty)) > checkTypeDecl withExt _ (TypeDecl p r tvs (RecordType fs rty))
> | not withExt = errorAt (positionOfIdent r) noRecordExt > | not withExt = errorAt (positionOfIdent r) noRecordExt
> | isJust rty = internalError "checkTypeDecl - illegal record type" > | isJust rty = internalError "SyntaxCheck.checkTypeDecl - illegal record type"
> | null fs = errorAt (positionOfIdent r) emptyRecord > | null fs = errorAt (positionOfIdent r) emptyRecord
> | otherwise = TypeDecl p r tvs (RecordType fs Nothing) > | otherwise = TypeDecl p r tvs (RecordType fs Nothing)
> checkTypeDecl _ _ d = d > checkTypeDecl _ _ d = d
...@@ -327,7 +327,7 @@ top-level. ...@@ -327,7 +327,7 @@ top-level.
> patDecl t > patDecl t
> | k == globalKey = errorAt p noToplevelPattern > | k == globalKey = errorAt p noToplevelPattern
> | otherwise = PatternDecl p' t rhs > | otherwise = PatternDecl p' t rhs
> checkEquationLhs _ _ _ _ _ _ = internalError "checkEquationLhs" > checkEquationLhs _ _ _ _ _ _ = internalError "SyntaxCheck.checkEquationLhs"
> checkEqLhs :: ModuleIdent -> Integer -> RenameEnv -> Position -> Lhs > checkEqLhs :: ModuleIdent -> Integer -> RenameEnv -> Position -> Lhs
> -> Either (Ident,Lhs) ConstrTerm > -> Either (Ident,Lhs) ConstrTerm
...@@ -648,13 +648,14 @@ top-level. ...@@ -648,13 +648,14 @@ top-level.
> checkExpr :: Bool -> Position -> ModuleIdent -> RenameEnv -> Expression > checkExpr :: Bool -> Position -> ModuleIdent -> RenameEnv -> Expression
> -> RenameState Expression > -> RenameState Expression
> checkExpr _ _ _ _ (Literal l) = liftM Literal (renameLiteral l) > checkExpr _ _ _ _ (Literal l) = liftM Literal (renameLiteral l)
> checkExpr _ _ m env (Variable v) = > checkExpr _ _ m env var@(Variable v)
> case (qualLookupVar v env) of > | unqualify v == anonId = return var
> [] -> errorAt' (undefinedVariable v) > | otherwise = case qualLookupVar v env of
> [Constr _] -> return (Constructor v) > [] -> errorAt' (undefinedVariable v)
> [GlobalVar _ _] -> return (Variable v) > [Constr _] -> return (Constructor v)
> [LocalVar _ v'] -> return (Variable (qualify v')) > [GlobalVar _ _] -> return (Variable v)
> rs -> case (qualLookupVar (qualQualify m v) env) of > [LocalVar _ v'] -> return (Variable (qualify v'))
> rs -> case qualLookupVar (qualQualify m v) env of
> [] -> errorAt' (ambiguousIdent rs v) > [] -> errorAt' (ambiguousIdent rs v)
> [Constr _] -> return (Constructor v) > [Constr _] -> return (Constructor v)
> [GlobalVar _ _] -> return (Variable v) > [GlobalVar _ _] -> return (Variable v)
...@@ -922,12 +923,12 @@ the user about the fact that the identifier is ambiguous. ...@@ -922,12 +923,12 @@ the user about the fact that the identifier is ambiguous.
> varIdent :: RenameInfo -> Ident > varIdent :: RenameInfo -> Ident
> varIdent (GlobalVar _ v) = unqualify v > varIdent (GlobalVar _ v) = unqualify v
> varIdent (LocalVar _ v) = v > varIdent (LocalVar _ v) = v
> varIdent _ = internalError "not a variable" > varIdent _ = internalError "SyntaxCheck.varIdent: not a variable"
> qualVarIdent :: RenameInfo -> QualIdent > qualVarIdent :: RenameInfo -> QualIdent
> qualVarIdent (GlobalVar _ v) = v > qualVarIdent (GlobalVar _ v) = v
> qualVarIdent (LocalVar _ v) = qualify v > qualVarIdent (LocalVar _ v) = qualify v
> qualVarIdent _ = internalError "not a qualified variable" > qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: not a qualified variable"
> arity :: RenameInfo -> Int > arity :: RenameInfo -> Int
> arity (Constr n) = n > arity (Constr n) = n
......
...@@ -63,7 +63,7 @@ The type checker returns the resulting type ...@@ -63,7 +63,7 @@ The type checker returns the resulting type
constructor and type environments. constructor and type environments.
\begin{verbatim} \begin{verbatim}
> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv,ValueEnv) > typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv, ValueEnv)
> typeCheck m tcEnv tyEnv ds = > typeCheck m tcEnv tyEnv ds =
> run (tcDecls m tcEnv' Map.empty vds >> > run (tcDecls m tcEnv' Map.empty vds >>
> S.lift S.get >>= \theta -> S.get >>= \tyEnv' -> > S.lift S.get >>= \theta -> S.get >>= \tyEnv' ->
...@@ -143,7 +143,7 @@ and \texttt{expandMonoTypes}, respectively. ...@@ -143,7 +143,7 @@ and \texttt{expandMonoTypes}, respectively.
> free _ = error "TypeCheck.sortTypeDecls.free: no pattern match" > free _ = error "TypeCheck.sortTypeDecls.free: no pattern match"
> typeDecl :: ModuleIdent -> [Decl] -> Decl > typeDecl :: ModuleIdent -> [Decl] -> Decl
> typeDecl _ [] = internalError "typeDecl" > typeDecl _ [] = internalError "TypeCheck.typeDecl"
> typeDecl _ [d@(DataDecl _ _ _ _)] = d > typeDecl _ [d@(DataDecl _ _ _ _)] = d
> typeDecl _ [d@(NewtypeDecl _ _ _ _)] = d > typeDecl _ [d@(NewtypeDecl _ _ _ _)] = d
> typeDecl m [d@(TypeDecl _ tc _ ty)] > typeDecl m [d@(TypeDecl _ tc _ ty)]
...@@ -340,7 +340,7 @@ either one of the basic types or \texttt{()}. ...@@ -340,7 +340,7 @@ either one of the basic types or \texttt{()}.
> where typeOf f' tcEnv' sigs' = > where typeOf f' tcEnv' sigs' =
> case lookupTypeSig f' sigs' of > case lookupTypeSig f' sigs' of
> Just ty -> return (expandPolyType m tcEnv' ty) > Just ty -> return (expandPolyType m tcEnv' ty)
> Nothing -> internalError "tcFlatExternalFunct" > Nothing -> internalError "TypeCheck.tcFlatExternalFunct"
> tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident > tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident
> -> TcState () > -> TcState ()
...@@ -425,8 +425,7 @@ signature the declared type must be too general. ...@@ -425,8 +425,7 @@ signature the declared type must be too general.
> tyEnv' = rebindFun m v sigma tyEnv > tyEnv' = rebindFun m v sigma tyEnv
> sigma = genType poly (subst theta (varType v tyEnv)) > sigma = genType poly (subst theta (varType v tyEnv))
> genType poly' (ForAll n ty) > genType poly' (ForAll n ty)
> | n > 0 = internalError ("genVar: " ++ showLine (positionOfIdent v) ++ > | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show ty
> show v ++ " :: " ++ show ty)
> | poly' = gen lvs ty > | poly' = gen lvs ty
> | otherwise = monoType ty > | otherwise = monoType ty
> cmpTypes (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2 > cmpTypes (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2
...@@ -474,7 +473,7 @@ signature the declared type must be too general. ...@@ -474,7 +473,7 @@ signature the declared type must be too general.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1) > unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >> > m ty1 >>
> unifyArgs doc ts1 ty2 > unifyArgs doc ts1 ty2
> unifyArgs _ _ _ = internalError "tcConstrTerm" > unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTerm"
> tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) = > tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) =
> do > do
> tyEnv <- S.get > tyEnv <- S.get
...@@ -486,7 +485,7 @@ signature the declared type must be too general. ...@@ -486,7 +485,7 @@ signature the declared type must be too general.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t') > unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t')
> m ty1 >> > m ty1 >>
> unifyArgs doc ts' ty2 > unifyArgs doc ts' ty2
> unifyArgs _ _ _ = internalError "tcConstrTerm" > unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTerm"
> tcConstrTerm m tcEnv sigs p (ParenPattern t) = tcConstrTerm m tcEnv sigs p t > tcConstrTerm m tcEnv sigs p (ParenPattern t) = tcConstrTerm m tcEnv sigs p t
> tcConstrTerm m tcEnv sigs p (TuplePattern _ ts) > tcConstrTerm m tcEnv sigs p (TuplePattern _ ts)
> | null ts = return unitType > | null ts = return unitType
...@@ -525,7 +524,7 @@ signature the declared type must be too general. ...@@ -525,7 +524,7 @@ signature the declared type must be too general.
> (doc $-$ text "Term:" <+> ppConstrTerm 0 t1) > (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >> > m ty1 >>
> unifyArgs doc ts1 ty2 > unifyArgs doc ts1 ty2
> unifyArgs _ _ ty = internalError ("tcConstrTerm: " ++ show ty) > unifyArgs _ _ ty = internalError $ "TypeCheck.tcConstrTerm: " ++ show ty
> tcConstrTerm m tcEnv sigs p (InfixFuncPattern t1 op t2) = > tcConstrTerm m tcEnv sigs p (InfixFuncPattern t1 op t2) =
> tcConstrTerm m tcEnv sigs p (FunctionPattern op [t1,t2]) > tcConstrTerm m tcEnv sigs p (FunctionPattern op [t1,t2])
> tcConstrTerm m tcEnv sigs p r@(RecordPattern fs rt) > tcConstrTerm m tcEnv sigs p r@(RecordPattern fs rt)
...@@ -573,7 +572,7 @@ because of possibly multiple occurrences of variables. ...@@ -573,7 +572,7 @@ because of possibly multiple occurrences of variables.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1) > unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >> > m ty1 >>
> unifyArgs doc ts1 ty2 > unifyArgs doc ts1 ty2
> unifyArgs _ _ _ = internalError "tcConstrTermFP" > unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTermFP"
> tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) = > tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) =
> do > do
> tyEnv <- S.get > tyEnv <- S.get
...@@ -585,7 +584,7 @@ because of possibly multiple occurrences of variables. ...@@ -585,7 +584,7 @@ because of possibly multiple occurrences of variables.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t') > unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t')
> m ty1 >> > m ty1 >>
> unifyArgs doc ts' ty2 > unifyArgs doc ts' ty2
> unifyArgs _ _ _ = internalError "tcConstrTermFP" > unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTermFP"
> tcConstrTermFP m tcEnv sigs p (ParenPattern t) = tcConstrTermFP m tcEnv sigs p t > tcConstrTermFP m tcEnv sigs p (ParenPattern t) = tcConstrTermFP m tcEnv sigs p t
> tcConstrTermFP m tcEnv sigs p (TuplePattern _ ts) > tcConstrTermFP m tcEnv sigs p (TuplePattern _ ts)
> | null ts = return unitType > | null ts = return unitType
...@@ -623,7 +622,7 @@ because of possibly multiple occurrences of variables. ...@@ -623,7 +622,7 @@ because of possibly multiple occurrences of variables.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1) > unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >> > m ty1 >>
> unifyArgs doc ts1 ty2 > unifyArgs doc ts1 ty2
> unifyArgs _ _ _ = internalError "tcConstrTermFP" > unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTermFP"
> tcConstrTermFP m tcEnv sigs p (InfixFuncPattern t1 op t2) = > tcConstrTermFP m tcEnv sigs p (InfixFuncPattern t1 op t2) =
> tcConstrTermFP m tcEnv sigs p (FunctionPattern op [t1,t2]) > tcConstrTermFP m tcEnv sigs p (FunctionPattern op [t1,t2])
> tcConstrTermFP m tcEnv sigs p r@(RecordPattern fs rt) > tcConstrTermFP m tcEnv sigs p r@(RecordPattern fs rt)
...@@ -689,7 +688,7 @@ because of possibly multiple occurrences of variables. ...@@ -689,7 +688,7 @@ because of possibly multiple occurrences of variables.
> tcExpr :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Expression > tcExpr :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Expression
> -> TcState Type > -> TcState Type
> tcExpr m _ _ _ (Literal l) = tcLiteral m l > tcExpr m _ _ _ (Literal l) = tcLiteral m l
> tcExpr m tcEnv sigs _ (Variable v) = > tcExpr m tcEnv sigs _ (Variable v) =
> case qualLookupTypeSig m v sigs of > case qualLookupTypeSig m v sigs of
> Just ty -> inst (expandPolyType m tcEnv ty) > Just ty -> inst (expandPolyType m tcEnv ty)
...@@ -772,7 +771,7 @@ because of possibly multiple occurrences of variables. ...@@ -772,7 +771,7 @@ because of possibly multiple occurrences of variables.
> 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 ("tcExpr unary " ++ name op') > | otherwise = internalError $ "TypeCheck.tcExpr unary " ++ name op'
> tcExpr m tcEnv sigs p e@(Apply e1 e2) = > tcExpr m tcEnv sigs p e@(Apply e1 e2) =
> do > do
> ty1 <- tcExpr m tcEnv sigs p e1 > ty1 <- tcExpr m tcEnv sigs p e1
...@@ -1079,7 +1078,7 @@ of~\cite{PeytonJones87:Book}). ...@@ -1079,7 +1078,7 @@ of~\cite{PeytonJones87:Book}).
> (unifyTypes m ty ty')) > (unifyTypes m ty ty'))
> (lookup l fs2)) > (lookup l fs2))
> (unifyTypedLabels m fs1 tr) > (unifyTypedLabels m fs1 tr)
> unifyTypedLabels _ _ _ = internalError "unifyTypedLabels" > unifyTypedLabels _ _ _ = internalError "TypeCheck.unifyTypedLabels"
\end{verbatim} \end{verbatim}
For each declaration group, the type checker has to ensure that no For each declaration group, the type checker has to ensure that no
...@@ -1159,40 +1158,35 @@ unambiguously refers to the local definition. ...@@ -1159,40 +1158,35 @@ unambiguously refers to the local definition.
\begin{verbatim} \begin{verbatim}
> constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme > constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
> constrType m c tyEnv = > constrType m c tyEnv = case qualLookupValue c tyEnv of
> case qualLookupValue c tyEnv of > [DataConstructor _ sigma] -> sigma
> [DataConstructor _ sigma] -> sigma > [NewtypeConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma > _ -> case qualLookupValue (qualQualify m c) tyEnv of
> _ -> case (qualLookupValue (qualQualify m c) tyEnv) of > [DataConstructor _ sigma] -> sigma
> [DataConstructor _ sigma] -> sigma > [NewtypeConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma > _ -> internalError $ "TypeCheck.constrType " ++ show c
> _ -> internalError ("constrType " ++ show c)
> varType :: Ident -> ValueEnv -> TypeScheme > varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv = > varType v tyEnv = case lookupValue v tyEnv of
> case lookupValue v tyEnv of > Value _ sigma : _ -> sigma
> Value _ sigma : _ -> sigma > _ -> internalError $ "TypeCheck.varType " ++ show v
> _ -> internalError ("varType " ++ show v)