Compiler messages now use Doc for message body

src/Base/Messages.hs

@@ -2,17 +2,16 @@ module Base.Messages
   ( -- * Output of user information
     info, status, putErrLn, putErrsLn
     -- * program abortion
-  , abortWith, internalError, errorMessage, errorMessages
+  , abortWith, abortWithMessages, internalError, errorMessage, errorMessages
     -- * creating messages
-  , Message, toMessage, posMsg, qposMsg, mposMsg
+  , Message, posMessage
   ) where
 
 import Control.Monad (unless)
-import System.IO (hPutStrLn, stderr)
-import System.Exit (ExitCode (..), exitWith)
+import System.IO     (hPutStrLn, stderr)
+import System.Exit   (exitFailure)
 
-import Curry.Base.Ident (ModuleIdent (..), Ident (..), QualIdent, qidPosition)
-import Curry.Base.MessageMonad (Message, toMessage)
+import Curry.Base.MessageMonad (Message, posMessage, ppMessage, ppMessages)
 
 import CompilerOpts (Options (optVerbosity), Verbosity (..))
 
@@ -34,23 +33,18 @@ putErrsLn = mapM_ putErrLn
 
 -- |Print a list of error messages on 'stderr' and abort the program
 abortWith :: [String] -> IO a
-abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)
+abortWith errs = putErrsLn errs >> exitFailure
+
+-- |Print a list of error messages on 'stderr' and abort the program
+abortWithMessages :: [Message] -> IO a
+abortWithMessages msgs = putErrLn (show $ ppMessages msgs) >> exitFailure
 
 -- |Raise an internal error
 internalError :: String -> a
 internalError msg = error $ "Internal error: " ++ msg
 
 errorMessage :: Message -> a
-errorMessage = error . show
+errorMessage = error . show . ppMessage
 
 errorMessages :: [Message] -> a
-errorMessages = error . unlines . map show
-
-posMsg :: Ident -> String -> Message
-posMsg i errMsg = toMessage (idPosition i) errMsg
-
-qposMsg :: QualIdent -> String -> Message
-qposMsg i errMsg = toMessage (qidPosition i) errMsg
-
-mposMsg :: ModuleIdent -> String -> Message
-mposMsg m errMsg = toMessage (midPosition m) errMsg
+errorMessages = error . show . ppMessages

src/Checks/ExportCheck.hs

@@ -6,12 +6,13 @@ import Data.List (nub, union)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
+import Text.PrettyPrint
 
 import Curry.Base.Ident
 import Curry.Base.Position
 import Curry.Syntax
 
-import Base.Messages (Message, internalError, mposMsg, posMsg, qposMsg)
+import Base.Messages (Message, internalError, posMessage)
 import Base.TopEnv
 import Base.Types
 import Base.Utils (findMultiples)
@@ -239,50 +240,53 @@ isRecordType _                                = False
 -- ---------------------------------------------------------------------------
 
 errUndefinedEntity :: QualIdent -> Message
-errUndefinedEntity x = qposMsg x $
-  "Entity " ++ qualName x ++ " in export list is not defined"
+errUndefinedEntity x = posMessage x $ hsep $ map text
+  ["Entity", qualName x, "in export list is not defined"]
 
 errUndefinedType :: QualIdent -> Message
-errUndefinedType tc = qposMsg tc $
-  "Type " ++ qualName tc ++ " in export list is not defined"
+errUndefinedType tc = posMessage tc $ hsep $ map text
+  ["Type", qualName tc, "in export list is not defined"]
 
 errModuleNotImported :: ModuleIdent -> Message
-errModuleNotImported m = mposMsg m $
-  "Module " ++ moduleName m ++ " not imported"
+errModuleNotImported m = posMessage m $ hsep $ map text
+  ["Module", moduleName m, "not imported"]
 
 errMultipleExportType :: [Ident] -> Message
 errMultipleExportType []     = internalError
   "Checks.ExportCheck.errMultipleExportType: empty list"
-errMultipleExportType (i:is) = posMsg i $
-  "Multiple exports of type " ++ idName i ++ " at:\n"
-  ++ unlines (map showPos (i:is))
-  where showPos = ("    " ++) . showLine . idPosition
+errMultipleExportType (i:is) = posMessage i $
+  text "Multiple exports of type" <+> text (idName i) <+> text "at:" $+$
+  nest 2 (vcat (map showPos (i:is)))
+  where showPos = text . showLine . idPosition
 
 errMultipleExportValue :: [Ident] -> Message
 errMultipleExportValue []     = internalError
   "Checks.ExportCheck.errMultipleExportValue: empty list"
-errMultipleExportValue (i:is) = posMsg i $
-  "Multiple exports of " ++ idName i ++ " at:\n"
-  ++ unlines (map showPos (i:is))
-  where showPos = ("    " ++) . showLine . idPosition
+errMultipleExportValue (i:is) = posMessage i $
+  text "Multiple exports of" <+> text (idName i) <+> text "at:" $+$
+  nest 2 (vcat (map showPos (i:is)))
+  where showPos = text . showLine . idPosition
 
 errAmbiguousType :: QualIdent -> Message
-errAmbiguousType tc = qposMsg tc $ "Ambiguous type " ++ qualName tc
+errAmbiguousType tc = posMessage tc $ hsep $ map text
+  ["Ambiguous type", qualName tc]
 
 errAmbiguousName :: QualIdent -> Message
-errAmbiguousName x = qposMsg x $ "Ambiguous name " ++ qualName x
+errAmbiguousName x = posMessage x $ hsep $ map text
+  ["Ambiguous name", qualName x]
 
 errExportDataConstr :: QualIdent -> Message
-errExportDataConstr c = qposMsg c $
-  "Data constructor " ++ qualName c ++ " in export list"
+errExportDataConstr c = posMessage c $ hsep $ map text
+  ["Data constructor", qualName c, "in export list"]
 
 errNonDataType :: QualIdent -> Message
-errNonDataType tc = qposMsg tc $ qualName tc ++ " is not a data type"
+errNonDataType tc = posMessage tc $ hsep $ map text
+  [qualName tc, "is not a data type"]
 
 errUndefinedDataConstr :: QualIdent -> Ident -> Message
-errUndefinedDataConstr tc c = posMsg c $
-  idName c ++ " is not a data constructor of type " ++ qualName tc
+errUndefinedDataConstr tc c = posMessage c $ hsep $ map text
+  [idName c, "is not a data constructor of type", qualName tc]
 
 errUndefinedLabel :: QualIdent -> Ident -> Message
-errUndefinedLabel r l = posMsg l $
-  idName l ++ " is not a label of the record " ++ qualName r
+errUndefinedLabel r l = posMessage l $ hsep $ map text
+  [idName l, "is not a label of the record", qualName r]

src/Checks/KindCheck.lhs

@@ -27,12 +27,13 @@ is defined more than once.
 
 > import Control.Monad (forM, liftM, liftM2, liftM3, unless, when)
 > import qualified Control.Monad.State as S (State, runState, gets, modify)
+> import Text.PrettyPrint
 
 > import Curry.Base.Ident
 > import Curry.Base.Position
 > import Curry.Syntax
 
-> import Base.Messages (Message, posMsg, qposMsg, internalError)
+> import Base.Messages (Message, posMessage, internalError)
 > import Base.TopEnv
 > import Base.Utils (findMultiples)
 
@@ -314,36 +315,43 @@ Error messages:
 \begin{verbatim}
 
 > errUndefinedType :: QualIdent -> Message
-> errUndefinedType tc = qposMsg tc $ "Undefined type " ++ qualName tc
+> errUndefinedType tc = posMessage tc $ hsep $ map text
+>   ["Undefined type", qualName tc]
 
 > errAmbiguousType :: QualIdent -> Message
-> errAmbiguousType tc = qposMsg tc $ "Ambiguous type " ++ qualName tc
+> errAmbiguousType tc = posMessage tc $ hsep $ map text
+>   ["Ambiguous type", qualName tc]
 
 > errMultipleDeclaration :: [Ident] -> Message
 > errMultipleDeclaration []     = internalError
 >   "KindCheck.errMultipleDeclaration: empty list"
-> errMultipleDeclaration (i:is) = posMsg i $
->   "Multiple declarations for type `" ++ idName i ++ "` at:\n"
->   ++ unlines (map showPos (i:is))
->   where showPos = ("    " ++) . showLine . idPosition
+> errMultipleDeclaration (i:is) = posMessage i $
+>   text "Multiple declarations for type" <+> text (escName i)
+>   <+> text "at:" $+$
+>   nest 2 (vcat (map showPos (i:is)))
+>   where showPos = text . showLine . idPosition
 
 > errNonLinear :: Ident -> Message
-> errNonLinear tv = posMsg tv $ "Type variable " ++ idName tv ++
->   " occurs more than once on left hand side of type declaration"
+> errNonLinear tv = posMessage tv $ hsep $ map text
+>   [ "Type variable", idName tv
+>   , "occurs more than once on left hand side of type declaration"]
 
 > errNoVariable :: Ident -> Message
-> errNoVariable tv = posMsg tv $ "Type constructor " ++ idName tv ++
->   " used in left hand side of type declaration"
+> errNoVariable tv = posMessage tv $ hsep $ map text
+>   [ "Type constructor", idName tv
+>   , "used in left hand side of type declaration"]
 
 > errWrongArity :: QualIdent -> Int -> Int -> Message
-> errWrongArity tc arity argc = qposMsg tc $
->   "Type constructor " ++ qualName tc ++ " expects " ++ arguments arity ++
->   " but is applied to " ++ show argc
+> errWrongArity tc arity argc = posMessage tc $
+>   text "Type constructor" <+> text (qualName tc)
+>   <+> text "expects" <+> text (arguments arity)
+>   <> comma <+> text "but is applied to" <+> text (show argc)
 >   where arguments 0 = "no arguments"
 >         arguments 1 = "1 argument"
 >         arguments n = show n ++ " arguments"
 
 > errUnboundVariable :: Ident -> Message
-> errUnboundVariable tv = posMsg tv $ "Unbound type variable " ++ idName tv
+> errUnboundVariable tv = posMessage tv $ hsep $ map text
+>   ["Unbound type variable", idName tv]
 
 \end{verbatim}

src/Checks/PrecCheck.lhs

@@ -21,13 +21,14 @@ of the operators involved.
 > import Control.Monad (liftM, liftM2, liftM3, unless, when)
 > import qualified Control.Monad.State as S (State, runState, gets, modify)
 > import Data.List (partition)
+> import Text.PrettyPrint
 
 > import Curry.Base.Ident
 > import Curry.Base.Position
 > import Curry.Syntax
 
 > import Base.Expr
-> import Base.Messages (Message, posMsg, qposMsg)
+> import Base.Messages (Message, posMessage)
 > import Base.Utils (findDouble)
 
 > import Env.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
@@ -490,21 +491,21 @@ Error messages.
 \begin{verbatim}
 
 > errUndefinedOperator :: Ident -> Message
-> errUndefinedOperator op = posMsg op $
->   "no definition for " ++ idName op ++ " in this scope"
+> errUndefinedOperator op = posMessage op $ hsep $ map text
+>   ["No definition for", idName op, "in this scope"]
 
 > errDuplicatePrecedence :: Ident -> Message
-> errDuplicatePrecedence op = posMsg op $
->   "More than one fixity declaration for " ++ idName op
+> errDuplicatePrecedence op = posMessage op $ hsep $ map text
+>   ["More than one fixity declaration for", idName op]
 
 > errInvalidParse :: String -> Ident -> QualIdent -> Message
-> errInvalidParse what op1 op2 = posMsg op1 $
->   "Invalid use of " ++ what ++ " " ++ idName op1
->   ++ " with " ++ qualName op2 ++ (showLine $ qidPosition op2)
+> errInvalidParse what op1 op2 = posMessage op1 $ hsep $ map text
+>   [ "Invalid use of", what, idName op1, "with", qualName op2
+>   , showLine $ qidPosition op2]
 
 > errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message
-> errAmbiguousParse what op1 op2 = qposMsg op1 $
->   "Ambiguous use of " ++ what ++ " " ++ qualName op1
->   ++ " with " ++ qualName op2 ++ (showLine $ qidPosition op2)
+> errAmbiguousParse what op1 op2 = posMessage op1 $ hsep $ map text
+>   ["Ambiguous use of", what, qualName op1, "with", qualName op2
+>   , showLine $ qidPosition op2]
 
 \end{verbatim}

src/Checks/SyntaxCheck.lhs

@@ -27,13 +27,14 @@ definition.
 > import Data.List ((\\), insertBy, partition)
 > import Data.Maybe (fromJust, isJust, isNothing, maybeToList)
 > import qualified Data.Set as Set (empty, insert, member)
+> import Text.PrettyPrint
 
 > import Curry.Base.Ident
 > import Curry.Base.Position
 > import Curry.Syntax
 
 > import Base.Expr
-> import Base.Messages (Message, toMessage, internalError, posMsg, qposMsg)
+> import Base.Messages (Message, posMessage, internalError)
 > import Base.NestEnv
 > import Base.Types
 > import Base.Utils ((++!), findDouble, findMultiples)
@@ -982,113 +983,122 @@ Error messages.
 \begin{verbatim}
 
 > errUndefinedVariable :: QualIdent -> Message
-> errUndefinedVariable v = qposMsg v $ qualName v ++ " is undefined"
+> errUndefinedVariable v = posMessage v $ hsep $ map text
+>   [qualName v, "is undefined"]
 
 > errUndefinedData :: QualIdent -> Message
-> errUndefinedData c = qposMsg c $ "Undefined data constructor " ++ qualName c
+> errUndefinedData c = posMessage c $ hsep $ map text
+>   ["Undefined data constructor", qualName c]
 
 > errUndefinedLabel :: Ident -> Message
-> errUndefinedLabel l = posMsg l $ "Undefined record label `" ++ idName l ++ "`"
+> errUndefinedLabel l = posMessage l $  hsep $ map text
+>   ["Undefined record label", escName l]
 
 > errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
 > errAmbiguousIdent rs | any isConstr rs = errAmbiguousData
 >                      | otherwise       = errAmbiguousVariable
 
 > errAmbiguousVariable :: QualIdent -> Message
-> errAmbiguousVariable v = qposMsg v $ "Ambiguous variable " ++ qualName v
+> errAmbiguousVariable v = posMessage v $ hsep $ map text
+>   ["Ambiguous variable", qualName v]
 
 > errAmbiguousData :: QualIdent -> Message
-> errAmbiguousData c = qposMsg c $ "Ambiguous data constructor " ++ qualName c
+> errAmbiguousData c = posMessage c $  hsep $ map text
+>   ["Ambiguous data constructor", qualName c]
 
 > errDuplicateDefinition :: Ident -> Message
-> errDuplicateDefinition v = posMsg v $
->   "More than one definition for `" ++ idName v ++ "`"
+> errDuplicateDefinition v = posMessage v $ hsep $ map text
+>   ["More than one definition for", escName v]
 
 > errDuplicateVariable :: Ident -> Message
-> errDuplicateVariable v = posMsg v $
->   idName v ++ " occurs more than once in pattern"
+> errDuplicateVariable v = posMessage v $ hsep $ map text
+>   [idName v, "occurs more than once in pattern"]
 
 > errMultipleDataConstructor :: [Ident] -> Message
 > errMultipleDataConstructor [] = internalError
 >   "SyntaxCheck.errMultipleDataDeclaration: empty list"
-> errMultipleDataConstructor (i:is) = posMsg i $
->   "Multiple definitions for data constructor `" ++ idName i ++ "` at:\n"
->   ++ unlines (map showPos (i:is))
->   where showPos = ("    " ++) . showLine . idPosition
+> errMultipleDataConstructor (i:is) = posMessage i $
+>   text "Multiple definitions for data constructor" <+> text (escName i)
+>   <+> text "at:" $+$
+>   nest 2 (vcat (map showPos (i:is)))
+>   where showPos = text . showLine . idPosition
 
 > errDuplicateTypeSig :: Ident -> Message
-> errDuplicateTypeSig v = posMsg v $
->   "More than one type signature for `" ++ idName v ++ "`"
+> errDuplicateTypeSig v = posMessage v $ hsep $ map text
+>   ["More than one type signature for", escName v]
 
 > errDuplicateEvalAnnot :: Ident -> Message
-> errDuplicateEvalAnnot v = posMsg v $
->   "More than one eval annotation for `" ++ idName v ++ "`"
+> errDuplicateEvalAnnot v = posMessage v $ hsep $ map text
+>   ["More than one eval annotation for", escName v]
 
 > errDuplicateLabel :: Ident -> Message
-> errDuplicateLabel l = posMsg l $
->   "Multiple occurrence of record label `" ++ idName l ++ "`"
+> errDuplicateLabel l = posMessage l $ hsep $ map text
+>   ["Multiple occurrence of record label", escName l]
 
 > errMissingLabel :: Position -> Ident -> QualIdent -> String -> Message
-> errMissingLabel p l r what = toMessage p $
->   "Missing label `" ++ idName l
->   ++ "` in the " ++ what ++ " of `" ++ idName (unqualify r) ++ "`"
+> errMissingLabel p l r what = posMessage p $ hsep $ map text
+>   ["Missing label", escName l, "in the", what, "of", escName (unqualify r)]
 
 > errIllegalLabel :: Ident -> QualIdent -> Message
-> errIllegalLabel l r = posMsg l $
->   "Label `" ++ idName l ++ "` is not defined in record `"
->   ++ idName (unqualify r) ++ "`"
+> errIllegalLabel l r = posMessage l $ hsep $ map text
+>   ["Label", escName l, "is not defined in record", escName (unqualify r)]
 
 > errIllegalRecordId :: Ident -> Message
-> errIllegalRecordId r = posMsg r $ "Record identifier `" ++ idName r
->     ++ "` already assigned to a data constructor"
+> errIllegalRecordId r = posMessage r $ hsep $ map text
+>   ["Record identifier", escName r, "already assigned to a data constructor"]
 
 > errNonVariable :: String -> Ident -> Message
-> errNonVariable what c = posMsg c $
->   "Data constructor `" ++ idName c ++ "` in left hand side of " ++ what
+> errNonVariable what c = posMessage c $ hsep $ map text
+>   ["Data constructor", escName c, "in left hand side of", what]
 
 > errNoBody :: Ident -> Message
-> errNoBody v = posMsg v $ "No body for `" ++ idName v ++ "`"
+> errNoBody v = posMessage v $  hsep $ map text ["No body for", escName v]
 
 > errNoTypeSig :: Ident -> Message
-> errNoTypeSig f = posMsg f $
->   "No type signature for external function `" ++ idName f ++ "`"
+> errNoTypeSig f = posMessage f $ hsep $ map text
+>   ["No type signature for external function", escName f]
 
 > errToplevelPattern :: Position -> Message
-> errToplevelPattern p = toMessage p
+> errToplevelPattern p = posMessage p $ text
 >   "Pattern declaration not allowed at top-level"
 
 > errNotALabel :: Ident -> Message
-> errNotALabel l = posMsg l $ "`" ++ idName l ++ "` is not a record label"
+> errNotALabel l = posMessage l $
+>   text (escName l) <+> text "is not a record label"
 
 > errDifferentArity :: Ident -> Message
-> errDifferentArity f = posMsg f $
->   "Equations for `" ++ idName f ++ "` have different arities"
+> errDifferentArity f = posMessage f $ hsep $ map text
+>   ["Equations for", escName f, "have different arities"]
 
 > errWrongArity :: QualIdent -> Int -> Int -> Message
-> errWrongArity c arity' argc = qposMsg c $
->   "Data constructor " ++ qualName c ++ " expects " ++ arguments arity' ++
->   " but is applied to " ++ show argc
+> errWrongArity c arity' argc = posMessage c $ hsep (map text
+>   ["Data constructor", qualName c, "expects", arguments arity'])
+>   <> comma <+> text "but is applied to" <+> text (show argc)
 >   where arguments 0 = "no arguments"
 >         arguments 1 = "1 argument"
 >         arguments n = show n ++ " arguments"
 
 > errIllegalRecordPattern :: Position -> Message
-> errIllegalRecordPattern p = toMessage p
->   "Expexting `_` after `|` in the record pattern"
+> errIllegalRecordPattern p = posMessage p $ hsep $ map text
+>   [ "Expexting", escName anonId, "after", escName (mkIdent "|")
+>   , "in the record pattern" ]
 
 > errMissingLanguageExtension :: Position -> String -> Extension -> Message
-> errMissingLanguageExtension p what ext = toMessage p $
->   what ++ " are not supported in standard Curry."
->   ++ "\n  Use flag -e or -X" ++ show ext ++ " to enable this extension."
+> errMissingLanguageExtension p what ext = posMessage p $
+>   text what <+> text "are not supported in standard Curry." $+$
+>   nest 2 (text "Use flag -e or -X" <> text (show ext)
+>           <+> text "to enable this extension.")
 
 > errEmptyRecord :: Position -> Message
-> errEmptyRecord p = toMessage p "empty records are not allowed"
+> errEmptyRecord p = posMessage p $ text "Empty records are not allowed"
 
 > errInfixWithoutParens :: Position -> [(QualIdent, QualIdent)] -> Message
-> errInfixWithoutParens p calls = toMessage p $
->   "Missing parens in infix patterns: \n" ++ unlines (map showCall calls)
->   where showCall (q1, q2) =
->           show q1 ++ " " ++ showLine (qidPosition q1)
->           ++ "calls " ++ show q2 ++ " " ++ showLine (qidPosition q2)
+> errInfixWithoutParens p calls = posMessage p $
+>   text "Missing parens in infix patterns:" $+$
+>   vcat (map showCall calls)
+>   where
+>   showCall (q1, q2) = showWithPos q1 <+> text "calls" <+> showWithPos q2
+>   showWithPos q =  text (qualName q)
+>                <+> parens (text $ showLine $ qidPosition q)
 
 \end{verbatim}

src/Checks/TypeCheck.lhs

@@ -38,7 +38,7 @@ type annotation is present.
 
 > import Base.CurryTypes (fromQualType, toType, toTypes)
 > import Base.Expr
-> import Base.Messages (Message, toMessage, posMsg, internalError)
+> import Base.Messages (Message, posMessage, internalError)
 > import Base.SCC
 > import Base.TopEnv
 > import Base.Types
@@ -1320,39 +1320,39 @@ Error functions.
 > errRecursiveTypes :: [Ident] -> Message
 > errRecursiveTypes []         = internalError
 >   "TypeCheck.recursiveTypes: empty list"
-> errRecursiveTypes [tc]       = posMsg tc $
->   "Recursive synonym type " ++ idName tc
-> errRecursiveTypes (tc : tcs) = posMsg tc $
->   "Recursive synonym types " ++ idName tc ++ types "" tcs
+> errRecursiveTypes [tc]       = posMessage tc $ hsep $ map text
+>   ["Recursive synonym type", idName tc]
+> errRecursiveTypes (tc : tcs) = posMessage tc $
+>   text "Recursive synonym types" <+> text (idName tc) <+> types empty tcs
 >   where
->   types _    []         = ""
->   types comm [tc1]      = comm ++ " and " ++ idName tc1
->                           ++ showLine (idPosition tc1)
->   types _    (tc1:tcs1) = ", " ++ idName tc1
->                           ++ showLine (idPosition tc1)
->                           ++ types "," tcs1
+>   types _    []         = empty
+>   types comm [tc1]      = comm <+> text "and" <+> text (idName tc1)
+>                           <+> parens (text $ showLine $ idPosition tc1)
+>   types _    (tc1:tcs1) = comma <+> text (idName tc1) <+>
+>                           parens (text $ showLine $ idPosition tc1)
+>                           <> types comma tcs1
 
 > errPolymorphicFreeVar :: Ident -> Message
-> errPolymorphicFreeVar v = posMsg v $
->   "Free variable " ++ idName v ++ " has a polymorphic type"
+> errPolymorphicFreeVar v = posMessage v $ hsep $ map text
+>   ["Free variable", idName v, "has a polymorphic type"]
 
 > errTypeSigTooGeneral :: Position -> ModuleIdent -> Doc -> TypeExpr -> TypeScheme
 >                      -> Message
-> errTypeSigTooGeneral p m what ty sigma = toMessage p $ show $ vcat
+> errTypeSigTooGeneral p m what ty sigma = posMessage p $ vcat
 >   [ text "Type signature too general", what
 >   , text "Inferred type:"  <+> ppTypeScheme m sigma
 >   , text "Type signature:" <+> ppTypeExpr 0 ty
 >   ]
 
 > errNonFunctionType :: Position -> String -> Doc -> ModuleIdent -> Type -> Message
-> errNonFunctionType p what doc m ty = toMessage p $ show $ vcat
+> errNonFunctionType p what doc m ty = posMessage p $ vcat
 >   [ text "Type error in" <+> text what, doc
 >   , text "Type:" <+> ppType m ty
 >   , text "Cannot be applied"
 >   ]
 
 > errNonBinaryOp :: Position -> String -> Doc -> ModuleIdent -> Type -> Message
-> errNonBinaryOp p what doc m ty = toMessage p $ show $ vcat
+> errNonBinaryOp p what doc m ty = posMessage p $ vcat
 >   [ text "Type error in" <+> text what, doc
 >   , text "Type:" <+> ppType m ty
 >   , text "Cannot be used as binary operator"
@@ -1360,7 +1360,7 @@ Error functions.
 
 > errTypeMismatch :: Position -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc
 >                 -> Message
-> errTypeMismatch p what doc m ty1 ty2 reason = toMessage p $ show $ vcat
+> errTypeMismatch p what doc m ty1 ty2 reason = posMessage p $ vcat
 >   [ text "Type error in"  <+> text what, doc
 >   , text "Inferred type:" <+> ppType m ty2
 >   , text "Expected type:" <+> ppType m ty1
@@ -1368,7 +1368,7 @@ Error functions.
 >   ]
 
 > errSkolemEscapingScope :: Position -> ModuleIdent -> Doc -> Type -> Message
-> errSkolemEscapingScope p m what ty = toMessage p $ show $ vcat
+> errSkolemEscapingScope p m what ty = posMessage p $ vcat
 >   [ text "Existential type escapes out of its scope"
 >   , what, text "Type:" <+> ppType m ty
 >   ]

src/Checks/WarnCheck.hs

@@ -18,12 +18,13 @@ import Control.Monad.State
   (State, execState, filterM, gets, modify, unless, when, foldM_)
 import qualified Data.Map as Map (empty, insert, lookup)
 import Data.List (intersect, intersectBy, unionBy)
+import Text.PrettyPrint
 
 import Curry.Base.Ident
 import Curry.Base.Position
 import Curry.Syntax
 
-import Base.Messages (Message, toMessage)
+import Base.Messages (Message, posMessage)
 import qualified Base.ScopeEnv as ScopeEnv
 
 import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
@@ -738,43 +739,39 @@ typeId ident = qualify (renameIdent ident 1)
 -- ---------------------------------------------------------------------------
 
 warnMultiplyImportedModule :: ModuleIdent -> Message
-warnMultiplyImportedModule mid = toMessage (midPosition mid) $
-  "Module \"" ++ show mid ++ "\" is imported more than once"
+warnMultiplyImportedModule mid = posMessage mid $ hsep $ map text
+  ["Module", moduleName mid, "is imported more than once"]
 
 warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message