Internal errors improved, KindCheck improved

src/Base/CurryTypes.lhs

@@ -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

src/Base/Typing.lhs

@@ -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}

src/Checks.hs

@@ -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

src/Checks/PrecCheck.lhs

@@ -38,13 +38,11 @@ imported precedence environment.
 \begin{verbatim}
 
 > bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv
-> bindPrecs m ds pEnv =
->   case findDouble ops of
->     Nothing ->
->       case [ op | op <- ops, op `notElem` bvs] of
->         [] -> foldr bindPrec pEnv fixDs
->         op : _ -> errorAt' (undefinedOperator op)
->     Just op -> errorAt' (duplicatePrecedence op)
+> bindPrecs m ds pEnv = case findDouble ops of
+>   Nothing -> case [ op | op <- ops, op `notElem` bvs] of
+>     [] -> foldr bindPrec pEnv fixDs
+>     op : _ -> errorAt' (undefinedOperator op)
+>   Just op -> errorAt' (duplicatePrecedence op)
 >   where (fixDs,nonFixDs) = partition isInfixDecl ds
 >         bvs = concatMap boundValues nonFixDs
 >         ops = [ op | InfixDecl _ _ _ ops' <- fixDs, op <- ops']
@@ -56,8 +54,8 @@ imported precedence environment.
 
 > boundValues :: Decl -> [Ident]
 > boundValues (DataDecl _ _ _ cs) = map constr cs
->   where constr (ConstrDecl _ _ c _) = c
->         constr (ConOpDecl _ _ _ op _) = op
+>   where constr (ConstrDecl _ _   c  _) = c
+>         constr (ConOpDecl  _ _ _ op _) = op
 > boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
 > boundValues (FunctionDecl _ f _) = [f]
 > boundValues (ExternalDecl _ _ _ f _) = [f]
@@ -77,13 +75,13 @@ be returned because it is needed for constructing the module's
 interface.
 \begin{verbatim}
 
-> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
+> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv, [Decl])
 > precCheck = checkDecls
 
-> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
-> checkDecls m pEnv ds = pEnv' `seq` (pEnv',ds')
+> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv, [Decl])
+> checkDecls m pEnv ds = pEnv' `seq` (pEnv', ds')
 >   where pEnv' = bindPrecs m ds pEnv
->         ds' = map (checkDecl m pEnv') ds
+>         ds'   = map (checkDecl m pEnv') ds
 
 > checkDecl :: ModuleIdent -> PEnv -> Decl -> Decl
 > checkDecl m pEnv (FunctionDecl p f eqs) =
@@ -430,10 +428,9 @@ an operator definition that shadows an imported definition.
 > opPrec op = prec (opName op)
 
 > prec :: QualIdent -> PEnv -> OpPrec
-> prec op env =
->   case qualLookupP op env of
->     [] -> defaultP
->     PrecInfo _ p : _ -> p
+> prec op env = case qualLookupP op env of
+>   [] -> defaultP
+>   PrecInfo _ p : _ -> p
 
 \end{verbatim}
 Error messages.

src/Checks/SyntaxCheck.lhs

@@ -127,12 +127,12 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
 >        [ArityInfo _ arity'] -> GlobalVar arity' qid
 >        rs                   -> case qualLookupArity qid' aEnv of
 >          [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)
 >                                         (find (\ (ArityInfo qid'' _) -> qid'' == qid) rs)
 > renameInfo tcEnv _    _    (Label _ r _) = case (qualLookupTC r tcEnv) of
 >   [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r (map fst fs)
->   _                                 -> internalError "renameInfo: no record"
+>   _                                 -> internalError "SyntaxCheck.renameInfo: no record"
 
 \end{verbatim}
 Since record types are currently translated into data types, it is
@@ -178,7 +178,7 @@ than once.
 
 > bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
 > 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)
 >		   in  bindGlobal m
 >	                          ident
@@ -199,7 +199,7 @@ than once.
 > bindVarDecl :: Decl -> RenameEnv -> RenameEnv
 > bindVarDecl (FunctionDecl _ ident equs) env
 >    | null equs
->      = internalError "bindFuncDecl: missing equations"
+>      = internalError "SyntaxCheck.bindFuncDecl: missing equations"
 >    | otherwise
 >      = let (_,ts) = getFlatLhs (head equs)
 >	 in  bindLocal (unRenameIdent ident) (LocalVar (length ts) ident) env
@@ -260,7 +260,7 @@ local declarations.
 > checkTypeDecl :: Bool -> ModuleIdent -> Decl -> Decl
 > checkTypeDecl withExt _ (TypeDecl p r tvs (RecordType fs rty))
 >   | 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
 >   | otherwise = TypeDecl p r tvs (RecordType fs Nothing)
 > checkTypeDecl _ _ d = d
@@ -327,7 +327,7 @@ top-level.
 >         patDecl t
 >           | k == globalKey = errorAt p noToplevelPattern
 >           | otherwise = PatternDecl p' t rhs
-> checkEquationLhs _ _ _ _ _ _ = internalError "checkEquationLhs"
+> checkEquationLhs _ _ _ _ _ _ = internalError "SyntaxCheck.checkEquationLhs"
 
 > checkEqLhs :: ModuleIdent -> Integer -> RenameEnv -> Position -> Lhs
 >            -> Either (Ident,Lhs) ConstrTerm
@@ -648,13 +648,14 @@ top-level.
 > checkExpr :: Bool -> Position -> ModuleIdent -> RenameEnv -> Expression
 >           -> RenameState Expression
 > checkExpr _ _ _ _ (Literal l) = liftM Literal (renameLiteral l)
-> checkExpr _ _ m env (Variable v) =
->   case (qualLookupVar v env) of
->     [] ->  errorAt' (undefinedVariable v)
->     [Constr _] -> return (Constructor v)
->     [GlobalVar _ _] -> return (Variable v)
->     [LocalVar _ v'] -> return (Variable (qualify v'))
->     rs -> case (qualLookupVar (qualQualify m v) env) of
+> checkExpr _ _ m env var@(Variable v)
+>    | unqualify v == anonId = return var
+>    | otherwise             = case qualLookupVar v env of
+>      [] ->  errorAt' (undefinedVariable v)
+>      [Constr _] -> return (Constructor v)
+>      [GlobalVar _ _] -> return (Variable v)
+>      [LocalVar _ v'] -> return (Variable (qualify v'))
+>      rs -> case qualLookupVar (qualQualify m v) env of
 >             [] -> errorAt' (ambiguousIdent rs v)
 >             [Constr _] -> return (Constructor v)
 >             [GlobalVar _ _] -> return (Variable v)
@@ -922,12 +923,12 @@ the user about the fact that the identifier is ambiguous.
 > varIdent :: RenameInfo -> Ident
 > varIdent (GlobalVar _ v) = unqualify v
 > varIdent (LocalVar _ v) =  v
-> varIdent _ = internalError "not a variable"
+> varIdent _ = internalError "SyntaxCheck.varIdent: not a variable"
 
 > qualVarIdent :: RenameInfo -> QualIdent
 > qualVarIdent (GlobalVar _ v) = v
 > qualVarIdent (LocalVar _ v) = qualify v
-> qualVarIdent _ = internalError "not a qualified variable"
+> qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: not a qualified variable"
 
 > arity :: RenameInfo -> Int
 > arity (Constr n) = n

src/Checks/TypeCheck.lhs

@@ -63,7 +63,7 @@ The type checker returns the resulting type
 constructor and type environments.
 \begin{verbatim}
 
-> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv,ValueEnv)
+> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv, ValueEnv)
 > typeCheck m tcEnv tyEnv ds =
 >   run (tcDecls m tcEnv' Map.empty vds >>
 >        S.lift S.get >>= \theta -> S.get >>= \tyEnv' ->
@@ -143,7 +143,7 @@ and \texttt{expandMonoTypes}, respectively.
 >         free _ = error "TypeCheck.sortTypeDecls.free: no pattern match"
 
 > typeDecl :: ModuleIdent -> [Decl] -> Decl
-> typeDecl _ [] = internalError "typeDecl"
+> typeDecl _ [] = internalError "TypeCheck.typeDecl"
 > typeDecl _ [d@(DataDecl _ _ _ _)] = d
 > typeDecl _ [d@(NewtypeDecl _ _ _ _)] = d
 > typeDecl m [d@(TypeDecl _ tc _ ty)]
@@ -340,7 +340,7 @@ either one of the basic types or \texttt{()}.
 >   where typeOf f' tcEnv' sigs' =
 >           case lookupTypeSig f' sigs' of
 >             Just ty -> return (expandPolyType m tcEnv' ty)
->             Nothing -> internalError "tcFlatExternalFunct"
+>             Nothing -> internalError "TypeCheck.tcFlatExternalFunct"
 
 > tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident
 >            -> TcState ()
@@ -425,8 +425,7 @@ signature the declared type must be too general.
 >         tyEnv' = rebindFun m v sigma tyEnv
 >         sigma = genType poly (subst theta (varType v tyEnv))
 >         genType poly' (ForAll n ty)
->           | n > 0 = internalError ("genVar: " ++ showLine (positionOfIdent v) ++
->                                    show v ++ " :: " ++ show ty)
+>           | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show ty
 >           | poly' = gen lvs ty
 >           | otherwise = monoType ty
 >         cmpTypes (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2
@@ -474,7 +473,7 @@ signature the declared type must be too general.
 >           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
 >                 m ty1 >>
 >           unifyArgs doc ts1 ty2
->         unifyArgs _ _ _ = internalError "tcConstrTerm"
+>         unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTerm"
 > tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) =
 >   do
 >     tyEnv <- S.get
@@ -486,7 +485,7 @@ signature the declared type must be too general.
 >           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t')
 >                 m ty1 >>
 >           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 (TuplePattern _ ts)
 >  | null ts = return unitType
@@ -525,7 +524,7 @@ signature the declared type must be too general.
 >	          (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
 >                 m ty1 >>
 >           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 (FunctionPattern op [t1,t2])
 > tcConstrTerm m tcEnv sigs p r@(RecordPattern fs rt)
@@ -573,7 +572,7 @@ because of possibly multiple occurrences of variables.
 >           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
 >                 m ty1 >>
 >           unifyArgs doc ts1 ty2
->         unifyArgs _ _ _ = internalError "tcConstrTermFP"
+>         unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTermFP"
 > tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) =
 >   do
 >     tyEnv <- S.get
@@ -585,7 +584,7 @@ because of possibly multiple occurrences of variables.
 >           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t')
 >                 m ty1 >>
 >           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 (TuplePattern _ ts)
 >  | null ts = return unitType
@@ -623,7 +622,7 @@ because of possibly multiple occurrences of variables.
 >           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
 >                 m ty1 >>
 >           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 (FunctionPattern op [t1,t2])
 > tcConstrTermFP m tcEnv sigs p r@(RecordPattern fs rt)
@@ -689,7 +688,7 @@ because of possibly multiple occurrences of variables.
 
 > tcExpr :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Expression
 >        -> TcState Type
-> tcExpr m _ _ _ (Literal l) = tcLiteral m l
+> tcExpr m _     _    _ (Literal  l) = tcLiteral m l
 > tcExpr m tcEnv sigs _ (Variable v) =
 >   case qualLookupTypeSig m v sigs of
 >     Just ty -> inst (expandPolyType m tcEnv ty)
@@ -772,7 +771,7 @@ because of possibly multiple occurrences of variables.
 >   where opType op'
 >           | op' == minusId = freshConstrained [intType,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) =
 >   do
 >     ty1 <- tcExpr m tcEnv sigs p e1
@@ -1079,7 +1078,7 @@ of~\cite{PeytonJones87:Book}).
 >	                    (unifyTypes m ty ty'))
 >                  (lookup l fs2))
 >          (unifyTypedLabels m fs1 tr)
-> unifyTypedLabels _ _ _ = internalError "unifyTypedLabels"
+> unifyTypedLabels _ _ _ = internalError "TypeCheck.unifyTypedLabels"
 
 \end{verbatim}
 For each declaration group, the type checker has to ensure that no
@@ -1159,40 +1158,35 @@ unambiguously refers to the local definition.
 \begin{verbatim}
 
 > constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
-> constrType m c tyEnv =
->   case qualLookupValue c tyEnv of
->     [DataConstructor _ sigma] -> sigma
->     [NewtypeConstructor _ sigma] -> sigma
->     _ -> case (qualLookupValue (qualQualify m c) tyEnv) of
->            [DataConstructor _ sigma] -> sigma
->            [NewtypeConstructor _ sigma] -> sigma
->            _ -> internalError ("constrType " ++ show c)
+> constrType m c tyEnv = case qualLookupValue c tyEnv of
+>   [DataConstructor    _ sigma] -> sigma
+>   [NewtypeConstructor _ sigma] -> sigma
+>   _ -> case qualLookupValue (qualQualify m c) tyEnv of
+>          [DataConstructor    _ sigma] -> sigma
+>          [NewtypeConstructor _ sigma] -> sigma
+>          _ -> internalError $ "TypeCheck.constrType " ++ show c
 
 > varType :: Ident -> ValueEnv -> TypeScheme
-> varType v tyEnv =
->   case lookupValue v tyEnv of
->     Value _ sigma : _ -> sigma
->     _ -> internalError ("varType " ++ show v)
+> varType v tyEnv = case lookupValue v tyEnv of
+>   Value _ sigma : _ -> sigma
+>   _ -> internalError $ "TypeCheck.varType " ++ show v
 
 > sureVarType :: Ident -> ValueEnv -> Maybe TypeScheme
-> sureVarType v tyEnv =
->   case lookupValue v tyEnv of
->     Value _ sigma : _ -> Just sigma
->     _ -> Nothing
+> sureVarType v tyEnv = case lookupValue v tyEnv of
+>   Value _ sigma : _ -> Just sigma
+>   _ -> Nothing
 
 > funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
-> funType m f tyEnv =
->   case (qualLookupValue f tyEnv) of
->     [Value _ sigma] -> sigma
->     _ -> case (qualLookupValue (qualQualify m f) tyEnv) of
->             [Value _ sigma] -> sigma
->             _ -> internalError ("funType " ++ show f)
+> funType m f tyEnv = case qualLookupValue f tyEnv of
+>   [Value _ sigma] -> sigma
+>   _ -> case qualLookupValue (qualQualify m f) tyEnv of
+>          [Value _ sigma] -> sigma
+>          _ -> internalError $ "TypeCheck.funType " ++ show f
 
 > sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme
-> sureLabelType l tyEnv =
->   case lookupValue l tyEnv of
->     Label _ _ sigma : _ -> Just sigma
->     _ -> Nothing
+> sureLabelType l tyEnv = case lookupValue l tyEnv of
+>   Label _ _ sigma : _ -> Just sigma
+>   _ -> Nothing
 
 
 \end{verbatim}
@@ -1221,7 +1215,7 @@ in which the type was defined.
 >            [DataType tc' _ _] -> TypeConstructor tc' tys'
 >            [RenamingType tc' _ _] -> TypeConstructor tc' tys'
 >            [AliasType _ _ ty] -> expandAliasType tys' ty
->            _ -> internalError ("expandType " ++ show tc)
+>            _ -> internalError $ "TypeCheck.expandType " ++ show tc
 >   where tys' = map (expandType m tcEnv) tys
 > expandType _ _ (TypeVariable tv) = TypeVariable tv
 > expandType _ _ (TypeConstrained tys tv) = TypeConstrained tys tv

src/Env/Eval.lhs

@@ -24,8 +24,8 @@ The function \texttt{evalEnv} collects all evaluation annotations of
 the module by traversing the syntax tree.
 \begin{verbatim}
 
-> evalEnv :: [Decl] -> EvalEnv
-> evalEnv = foldr collectAnnotsDecl Map.empty
+> evalEnv :: Module -> EvalEnv
+> evalEnv (Module _ _ _ ds) = foldr collectAnnotsDecl Map.empty ds
 
 > initEEnv :: EvalEnv
 > initEEnv = Map.empty

src/Env/NestEnv.lhs

@@ -41,17 +41,17 @@ imported.
 >   = GlobalEnv (bindTopEnv "NestEnv.bindNestEnv" x y env)
 > bindNestEnv x y (LocalEnv genv env) =
 >   case Map.lookup x env of
->     Just _ -> internalError "bindNestEnv"
+>     Just _ -> internalError "NestEnv.bindNestEnv"
 >     Nothing -> LocalEnv genv (Map.insert x y env)
 
 > qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
 > qualBindNestEnv x y (GlobalEnv env)
 >   = GlobalEnv (qualBindTopEnv "NestEnv.qualBindNestEnv" x y env)
 > qualBindNestEnv x y (LocalEnv genv env)
->   | isQualified x = internalError "qualBindNestEnv"
+>   | isQualified x = internalError "NestEnv.qualBindNestEnv"
 >   | otherwise =
 >       case Map.lookup x' env of
->         Just _ -> internalError "qualBindNestEnv"
+>         Just _ -> internalError "NestEnv.qualBindNestEnv"
 >         Nothing -> LocalEnv genv (Map.insert x' y env)
 >   where x' = unqualify x
 

src/Env/TopEnv.lhs

@@ -71,7 +71,7 @@ imported.
 > predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
 > predefTopEnv x y (TopEnv env) =
 >   case Map.lookup x env of
->     Just _ -> internalError "predefTopEnv"
+>     Just _ -> internalError "TopEnv.predefTopEnv"
 >     Nothing -> TopEnv (Map.insert x [(Import [],y)] env)
 
 > importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
@@ -101,8 +101,8 @@ imported.
 >   TopEnv (Map.insert x (bindLocal y (entities x env)) env)
 >   where bindLocal y' ys
 >           | null [y'' | (Local,y'') <- ys] = (Local,y') : ys
->           | otherwise = internalError ("\"qualBindTopEnv " ++ show x
->                       ++ "\" failed in function \"" ++ fun ++ "\"")
+>           | otherwise = internalError $ "\"qualBindTopEnv " ++ show x
+>                       ++ "\" failed in function \"" ++ fun ++ "\""
 
 > rebindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
 > rebindTopEnv = qualRebindTopEnv . qualify
@@ -110,7 +110,7 @@ imported.
 > qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
 > qualRebindTopEnv x y (TopEnv env) =
 >   TopEnv (Map.insert x (rebindLocal (entities x env)) env)
->   where rebindLocal [] = internalError "qualRebindTopEnv"
+>   where rebindLocal [] = internalError "TopEnv.qualRebindTopEnv"
 >         rebindLocal ((Local,_) : ys) = (Local,y) : ys
 >         rebindLocal ((Import ms,y') : ys) = (Import ms,y') : rebindLocal ys
 
@@ -118,7 +118,7 @@ imported.
 > unbindTopEnv x (TopEnv env) =
 >   TopEnv (Map.insert x' (unbindLocal (entities x' env)) env)
 >   where x' = qualify x
->         unbindLocal [] = internalError "unbindTopEnv"
+>         unbindLocal [] = internalError "TopEnv.unbindTopEnv"
 >         unbindLocal ((Local,_) : ys) = ys
 >         unbindLocal ((Import ms,y) : ys) = (Import ms,y) : unbindLocal ys
 

src/Env/Value.lhs

@@ -13,10 +13,14 @@ are considered equal if their original names match.
 > module Env.Value
 >   ( ValueEnv, ValueInfo (..), bindGlobalInfo, bindFun, rebindFun, bindLabel
 >   , lookupValue, qualLookupValue, qualLookupCons, lookupTuple, tupleDCs
->   , initDCEnv ) where
+>   , initDCEnv, ppTypes ) where
+
+> import Text.PrettyPrint (Doc, vcat)
 
 > import Curry.Base.Ident
+> import Curry.Syntax
 
+> import Base.CurryTypes (fromQualType)
 > import Base.Types
 > import Base.Utils ((++!))
 
@@ -124,3 +128,22 @@ TODO: Match other patterns?
 >         constrType (ForAll n ty) n' = ForAllExist n n' . foldr TypeArrow ty
 
 \end{verbatim}
+The function \texttt{ppTypes} is used for pretty-printing the types
+from the type environment.
+\begin{verbatim}
+
+> ppTypes :: ModuleIdent -> ValueEnv -> Doc
+> ppTypes mid valueEnv = ppTypes' mid (localBindings valueEnv)
+>   where
+>   ppTypes' :: ModuleIdent -> [(Ident, ValueInfo)] -> Doc
+>   ppTypes' m = vcat . map (ppIDecl . mkDecl) . filter (isValue . snd)
+>     where mkDecl (v, Value _ (ForAll _ ty)) =
+>             IFunctionDecl undefined (qualify v) (arrowArity ty)
+>                          (fromQualType m ty)
+>           mkDecl _ = error "Modules.ppTypes.mkDecl: no pattern match"
+>           isValue (DataConstructor _ _) = False
+>           isValue (NewtypeConstructor _ _) = False
+>           isValue (Value _ _) = True
+>           isValue (Label _ _ _) = False
+
+\end{verbatim}

src/Exports.lhs

@@ -181,7 +181,7 @@ identifiers.
 >     in case lookupValue (head ls) tyEnv of
 >       [Label _ r' _] -> if r == r' then ExportTypeWith r ls
 >                                    else ExportTypeWith r []
->       _              -> internalError "exportType"
+>       _              -> internalError "Exports.exportType"
 >   | otherwise = ExportTypeWith (origName t) (constrs t)
 
 > exportRecord :: TypeInfo -> [Export]
@@ -247,7 +247,7 @@ exported function.
 > iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
 >   []                           -> ds
 >   [PrecInfo _ (OpPrec fix pr)] -> IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
->   _                            -> internalError "infixDecl"
+