1module Language.PureScript.Errors 2 ( module Language.PureScript.AST 3 , module Language.PureScript.Errors 4 ) where 5 6import Prelude.Compat 7import Protolude (ordNub) 8 9import Control.Arrow ((&&&)) 10import Control.Exception (displayException) 11import Control.Monad 12import Control.Monad.Error.Class (MonadError(..)) 13import Control.Monad.Trans.State.Lazy 14import Control.Monad.Writer 15import Data.Bifunctor (first, second) 16import Data.Bitraversable (bitraverse) 17import Data.Char (isSpace) 18import Data.Either (partitionEithers) 19import Data.Foldable (fold) 20import Data.Functor.Identity (Identity(..)) 21import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn) 22import qualified Data.List.NonEmpty as NEL 23import Data.List.NonEmpty (NonEmpty((:|))) 24import Data.Maybe (maybeToList, fromMaybe, mapMaybe) 25import qualified Data.Map as M 26import Data.Ord (Down(..)) 27import qualified Data.Set as S 28import qualified Data.Text as T 29import Data.Text (Text) 30import qualified GHC.Stack 31import Language.PureScript.AST 32import qualified Language.PureScript.Bundle as Bundle 33import qualified Language.PureScript.Constants.Prelude as C 34import qualified Language.PureScript.Constants.Prim as C 35import Language.PureScript.Crash 36import qualified Language.PureScript.CST.Errors as CST 37import qualified Language.PureScript.CST.Print as CST 38import Language.PureScript.Environment 39import Language.PureScript.Label (Label(..)) 40import Language.PureScript.Names 41import Language.PureScript.Pretty 42import Language.PureScript.Pretty.Common (endWith) 43import Language.PureScript.PSString (decodeStringWithReplacement) 44import Language.PureScript.Roles 45import Language.PureScript.Traversals 46import Language.PureScript.Types 47import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers 48import qualified System.Console.ANSI as ANSI 49import qualified Text.Parsec as P 50import qualified Text.Parsec.Error as PE 51import Text.Parsec.Error (Message(..)) 52import qualified Text.PrettyPrint.Boxes as Box 53 54-- | A type of error messages 55data SimpleErrorMessage 56 = InternalCompilerError Text Text 57 | ModuleNotFound ModuleName 58 | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) 59 | ErrorParsingModule P.ParseError 60 | ErrorParsingCSTModule CST.ParserError 61 | WarningParsingCSTModule CST.ParserWarning 62 | MissingFFIModule ModuleName 63 | UnnecessaryFFIModule ModuleName FilePath 64 | MissingFFIImplementations ModuleName [Ident] 65 | UnusedFFIImplementations ModuleName [Ident] 66 | InvalidFFIIdentifier ModuleName Text 67 | DeprecatedFFIPrime ModuleName Text 68 | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred 69 | InfiniteType SourceType 70 | InfiniteKind SourceType 71 | MultipleValueOpFixities (OpName 'ValueOpName) 72 | MultipleTypeOpFixities (OpName 'TypeOpName) 73 | OrphanTypeDeclaration Ident 74 | OrphanKindDeclaration (ProperName 'TypeName) 75 | OrphanRoleDeclaration (ProperName 'TypeName) 76 | RedefinedIdent Ident 77 | OverlappingNamesInLet 78 | UnknownName (Qualified Name) 79 | UnknownImport ModuleName Name 80 | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) 81 | UnknownExport Name 82 | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) 83 | ScopeConflict Name [ModuleName] 84 | ScopeShadowing Name (Maybe ModuleName) [ModuleName] 85 | DeclConflict Name Name 86 | ExportConflict (Qualified Name) (Qualified Name) 87 | DuplicateModule ModuleName 88 | DuplicateTypeClass (ProperName 'ClassName) SourceSpan 89 | DuplicateInstance Ident SourceSpan 90 | DuplicateTypeArgument Text 91 | InvalidDoBind 92 | InvalidDoLet 93 | CycleInDeclaration Ident 94 | CycleInTypeSynonym (NEL.NonEmpty (ProperName 'TypeName)) 95 | CycleInTypeClassDeclaration (NEL.NonEmpty (Qualified (ProperName 'ClassName))) 96 | CycleInKindDeclaration (NEL.NonEmpty (Qualified (ProperName 'TypeName))) 97 | CycleInModules (NEL.NonEmpty ModuleName) 98 | NameIsUndefined Ident 99 | UndefinedTypeVariable (ProperName 'TypeName) 100 | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) 101 | EscapedSkolem Text (Maybe SourceSpan) SourceType 102 | TypesDoNotUnify SourceType SourceType 103 | KindsDoNotUnify SourceType SourceType 104 | ConstrainedTypeUnified SourceType SourceType 105 | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified (Either SourceType Ident)] 106 | NoInstanceFound 107 SourceConstraint -- ^ constraint that could not be solved 108 Bool -- ^ whether eliminating unknowns with annotations might help 109 | AmbiguousTypeVariables SourceType [Int] 110 | UnknownClass (Qualified (ProperName 'ClassName)) 111 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] 112 | PossiblyInfiniteCoercibleInstance 113 | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType] 114 | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int 115 | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType 116 | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [SourceType] 117 | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] 118 | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] 119 | CannotFindDerivingType (ProperName 'TypeName) 120 | DuplicateLabel Label (Maybe Expr) 121 | DuplicateValueDeclaration Ident 122 | ArgListLengthsDiffer Ident 123 | OverlappingArgNames (Maybe Ident) 124 | MissingClassMember (NEL.NonEmpty (Ident, SourceType)) 125 | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) 126 | ExpectedType SourceType SourceType 127 -- | constructor name, expected argument count, actual argument count 128 | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int 129 | ExprDoesNotHaveType Expr SourceType 130 | PropertyIsMissing Label 131 | AdditionalProperty Label 132 | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (S.Set ModuleName) [SourceType] 133 | InvalidNewtype (ProperName 'TypeName) 134 | InvalidInstanceHead SourceType 135 | TransitiveExportError DeclarationRef [DeclarationRef] 136 | TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName] 137 | HiddenConstructors DeclarationRef (Qualified (ProperName 'ClassName)) 138 | ShadowedName Ident 139 | ShadowedTypeVar Text 140 | UnusedTypeVar Text 141 | UnusedName Ident 142 | UnusedDeclaration Ident 143 | WildcardInferredType SourceType Context 144 | HoleInferredType Text SourceType Context (Maybe TypeSearch) 145 | MissingTypeDeclaration Ident SourceType 146 | MissingKindDeclaration KindSignatureFor (ProperName 'TypeName) SourceType 147 | OverlappingPattern [[Binder]] Bool 148 | IncompleteExhaustivityCheck 149 | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) 150 | ImportHidingModule ModuleName 151 | UnusedImport ModuleName (Maybe ModuleName) 152 | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef] 153 | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef] 154 | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef] 155 | DuplicateSelectiveImport ModuleName 156 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) 157 | DuplicateImportRef Name 158 | DuplicateExportRef Name 159 | IntOutOfRange Integer Text Integer Integer 160 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] 161 | ImplicitQualifiedImportReExport ModuleName ModuleName [DeclarationRef] 162 | ImplicitImport ModuleName [DeclarationRef] 163 | HidingImport ModuleName [DeclarationRef] 164 | CaseBinderLengthDiffers Int [Binder] 165 | IncorrectAnonymousArgument 166 | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) 167 | CannotGeneralizeRecursiveFunction Ident SourceType 168 | CannotDeriveNewtypeForData (ProperName 'TypeName) 169 | ExpectedWildcard (ProperName 'TypeName) 170 | CannotUseBindWithDo Ident 171 -- | instance name, type class, expected argument count, actual argument count 172 | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int 173 -- | a user-defined warning raised by using the Warn type class 174 | UserDefinedWarning SourceType 175 -- | a declaration couldn't be used because it contained free variables 176 | UnusableDeclaration Ident [[Text]] 177 | CannotDefinePrimModules ModuleName 178 | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity)) 179 | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName))) 180 | QuantificationCheckFailureInKind Text 181 | QuantificationCheckFailureInType [Int] SourceType 182 | VisibleQuantificationCheckFailureInType Text 183 | UnsupportedTypeInKind SourceType 184 -- | Declared role was more permissive than inferred. 185 | RoleMismatch 186 Text -- ^ Type variable in question 187 Role -- ^ inferred role 188 Role -- ^ declared role 189 | InvalidCoercibleInstanceDeclaration [SourceType] 190 | UnsupportedRoleDeclaration 191 | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int 192 | DuplicateRoleDeclaration (ProperName 'TypeName) 193 deriving (Show) 194 195data ErrorMessage = ErrorMessage 196 [ErrorMessageHint] 197 SimpleErrorMessage 198 deriving (Show) 199 200newtype ErrorSuggestion = ErrorSuggestion Text 201 202-- | Get the source span for an error 203errorSpan :: ErrorMessage -> Maybe (NEL.NonEmpty SourceSpan) 204errorSpan = findHint matchSpan 205 where 206 matchSpan (PositionedError ss) = Just ss 207 matchSpan _ = Nothing 208 209-- | Get the module name for an error 210errorModule :: ErrorMessage -> Maybe ModuleName 211errorModule = findHint matchModule 212 where 213 matchModule (ErrorInModule mn) = Just mn 214 matchModule _ = Nothing 215 216findHint :: (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a 217findHint f (ErrorMessage hints _) = getLast . foldMap (Last . f) $ hints 218 219-- | Remove the module name and span hints from an error 220stripModuleAndSpan :: ErrorMessage -> ErrorMessage 221stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldStrip) hints) e 222 where 223 shouldStrip (ErrorInModule _) = True 224 shouldStrip (PositionedError _) = True 225 shouldStrip _ = False 226 227-- | Get the error code for a particular error type 228errorCode :: ErrorMessage -> Text 229errorCode em = case unwrapErrorMessage em of 230 InternalCompilerError{} -> "InternalCompilerError" 231 ModuleNotFound{} -> "ModuleNotFound" 232 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" 233 ErrorParsingModule{} -> "ErrorParsingModule" 234 ErrorParsingCSTModule{} -> "ErrorParsingModule" 235 WarningParsingCSTModule{} -> "WarningParsingModule" 236 MissingFFIModule{} -> "MissingFFIModule" 237 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule" 238 MissingFFIImplementations{} -> "MissingFFIImplementations" 239 UnusedFFIImplementations{} -> "UnusedFFIImplementations" 240 InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" 241 DeprecatedFFIPrime{} -> "DeprecatedFFIPrime" 242 FileIOError{} -> "FileIOError" 243 InfiniteType{} -> "InfiniteType" 244 InfiniteKind{} -> "InfiniteKind" 245 MultipleValueOpFixities{} -> "MultipleValueOpFixities" 246 MultipleTypeOpFixities{} -> "MultipleTypeOpFixities" 247 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" 248 OrphanKindDeclaration{} -> "OrphanKindDeclaration" 249 OrphanRoleDeclaration{} -> "OrphanRoleDeclaration" 250 RedefinedIdent{} -> "RedefinedIdent" 251 OverlappingNamesInLet -> "OverlappingNamesInLet" 252 UnknownName{} -> "UnknownName" 253 UnknownImport{} -> "UnknownImport" 254 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor" 255 UnknownExport{} -> "UnknownExport" 256 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor" 257 ScopeConflict{} -> "ScopeConflict" 258 ScopeShadowing{} -> "ScopeShadowing" 259 DeclConflict{} -> "DeclConflict" 260 ExportConflict{} -> "ExportConflict" 261 DuplicateModule{} -> "DuplicateModule" 262 DuplicateTypeClass{} -> "DuplicateTypeClass" 263 DuplicateInstance{} -> "DuplicateInstance" 264 DuplicateTypeArgument{} -> "DuplicateTypeArgument" 265 InvalidDoBind -> "InvalidDoBind" 266 InvalidDoLet -> "InvalidDoLet" 267 CycleInDeclaration{} -> "CycleInDeclaration" 268 CycleInTypeSynonym{} -> "CycleInTypeSynonym" 269 CycleInTypeClassDeclaration{} -> "CycleInTypeClassDeclaration" 270 CycleInKindDeclaration{} -> "CycleInKindDeclaration" 271 CycleInModules{} -> "CycleInModules" 272 NameIsUndefined{} -> "NameIsUndefined" 273 UndefinedTypeVariable{} -> "UndefinedTypeVariable" 274 PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym" 275 EscapedSkolem{} -> "EscapedSkolem" 276 TypesDoNotUnify{} -> "TypesDoNotUnify" 277 KindsDoNotUnify{} -> "KindsDoNotUnify" 278 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified" 279 OverlappingInstances{} -> "OverlappingInstances" 280 NoInstanceFound{} -> "NoInstanceFound" 281 AmbiguousTypeVariables{} -> "AmbiguousTypeVariables" 282 UnknownClass{} -> "UnknownClass" 283 PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" 284 PossiblyInfiniteCoercibleInstance -> "PossiblyInfiniteCoercibleInstance" 285 CannotDerive{} -> "CannotDerive" 286 InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" 287 MissingNewtypeSuperclassInstance{} -> "MissingNewtypeSuperclassInstance" 288 UnverifiableSuperclassInstance{} -> "UnverifiableSuperclassInstance" 289 InvalidDerivedInstance{} -> "InvalidDerivedInstance" 290 ExpectedTypeConstructor{} -> "ExpectedTypeConstructor" 291 CannotFindDerivingType{} -> "CannotFindDerivingType" 292 DuplicateLabel{} -> "DuplicateLabel" 293 DuplicateValueDeclaration{} -> "DuplicateValueDeclaration" 294 ArgListLengthsDiffer{} -> "ArgListLengthsDiffer" 295 OverlappingArgNames{} -> "OverlappingArgNames" 296 MissingClassMember{} -> "MissingClassMember" 297 ExtraneousClassMember{} -> "ExtraneousClassMember" 298 ExpectedType{} -> "ExpectedType" 299 IncorrectConstructorArity{} -> "IncorrectConstructorArity" 300 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType" 301 PropertyIsMissing{} -> "PropertyIsMissing" 302 AdditionalProperty{} -> "AdditionalProperty" 303 OrphanInstance{} -> "OrphanInstance" 304 InvalidNewtype{} -> "InvalidNewtype" 305 InvalidInstanceHead{} -> "InvalidInstanceHead" 306 TransitiveExportError{} -> "TransitiveExportError" 307 TransitiveDctorExportError{} -> "TransitiveDctorExportError" 308 HiddenConstructors{} -> "HiddenConstructors" 309 ShadowedName{} -> "ShadowedName" 310 UnusedName{} -> "UnusedName" 311 UnusedDeclaration{} -> "UnusedDeclaration" 312 ShadowedTypeVar{} -> "ShadowedTypeVar" 313 UnusedTypeVar{} -> "UnusedTypeVar" 314 WildcardInferredType{} -> "WildcardInferredType" 315 HoleInferredType{} -> "HoleInferredType" 316 MissingTypeDeclaration{} -> "MissingTypeDeclaration" 317 MissingKindDeclaration{} -> "MissingKindDeclaration" 318 OverlappingPattern{} -> "OverlappingPattern" 319 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" 320 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" 321 ImportHidingModule{} -> "ImportHidingModule" 322 UnusedImport{} -> "UnusedImport" 323 UnusedExplicitImport{} -> "UnusedExplicitImport" 324 UnusedDctorImport{} -> "UnusedDctorImport" 325 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" 326 DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" 327 DuplicateImport{} -> "DuplicateImport" 328 DuplicateImportRef{} -> "DuplicateImportRef" 329 DuplicateExportRef{} -> "DuplicateExportRef" 330 IntOutOfRange{} -> "IntOutOfRange" 331 ImplicitQualifiedImport{} -> "ImplicitQualifiedImport" 332 ImplicitQualifiedImportReExport{} -> "ImplicitQualifiedImportReExport" 333 ImplicitImport{} -> "ImplicitImport" 334 HidingImport{} -> "HidingImport" 335 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" 336 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument" 337 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder" 338 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction" 339 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData" 340 ExpectedWildcard{} -> "ExpectedWildcard" 341 CannotUseBindWithDo{} -> "CannotUseBindWithDo" 342 ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch" 343 UserDefinedWarning{} -> "UserDefinedWarning" 344 UnusableDeclaration{} -> "UnusableDeclaration" 345 CannotDefinePrimModules{} -> "CannotDefinePrimModules" 346 MixedAssociativityError{} -> "MixedAssociativityError" 347 NonAssociativeError{} -> "NonAssociativeError" 348 QuantificationCheckFailureInKind {} -> "QuantificationCheckFailureInKind" 349 QuantificationCheckFailureInType {} -> "QuantificationCheckFailureInType" 350 VisibleQuantificationCheckFailureInType {} -> "VisibleQuantificationCheckFailureInType" 351 UnsupportedTypeInKind {} -> "UnsupportedTypeInKind" 352 RoleMismatch {} -> "RoleMismatch" 353 InvalidCoercibleInstanceDeclaration {} -> "InvalidCoercibleInstanceDeclaration" 354 UnsupportedRoleDeclaration {} -> "UnsupportedRoleDeclaration" 355 RoleDeclarationArityMismatch {} -> "RoleDeclarationArityMismatch" 356 DuplicateRoleDeclaration {} -> "DuplicateRoleDeclaration" 357 358-- | A stack trace for an error 359newtype MultipleErrors = MultipleErrors 360 { runMultipleErrors :: [ErrorMessage] 361 } deriving (Show, Semigroup, Monoid) 362 363-- | Check whether a collection of errors is empty or not. 364nonEmpty :: MultipleErrors -> Bool 365nonEmpty = not . null . runMultipleErrors 366 367-- | Create an error set from a single simple error message 368errorMessage :: SimpleErrorMessage -> MultipleErrors 369errorMessage err = MultipleErrors [ErrorMessage [] err] 370 371-- | Create an error set from a single simple error message and source annotation 372errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors 373errorMessage' ss err = MultipleErrors [ErrorMessage [positionedError ss] err] 374 375-- | Create an error set from a single simple error message and source annotations 376errorMessage'' :: NEL.NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors 377errorMessage'' sss err = MultipleErrors [ErrorMessage [PositionedError sss] err] 378 379-- | Create an error from multiple (possibly empty) source spans, reversed sorted. 380errorMessage''' :: [SourceSpan] -> SimpleErrorMessage -> MultipleErrors 381errorMessage''' sss err = 382 maybe (errorMessage err) (flip errorMessage'' err) 383 . NEL.nonEmpty 384 . sortOn Down 385 $ filter (/= NullSourceSpan) sss 386 387-- | Create an error set from a single error message 388singleError :: ErrorMessage -> MultipleErrors 389singleError = MultipleErrors . pure 390 391-- | Lift a function on ErrorMessage to a function on MultipleErrors 392onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors 393onErrorMessages f = MultipleErrors . map f . runMultipleErrors 394 395-- | Add a hint to an error message 396addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors 397addHint hint = addHints [hint] 398 399-- | Add hints to an error message 400addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors 401addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hints ++ hints') se 402 403-- | A map from rigid type variable name/unknown variable pairs to new variables. 404data TypeMap = TypeMap 405 { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) 406 -- ^ a map from skolems to their new names, including source and naming info 407 , umUnknownMap :: M.Map Int Int 408 -- ^ a map from unification variables to their new names 409 , umNextIndex :: Int 410 -- ^ unknowns and skolems share a source of names during renaming, to 411 -- avoid overlaps in error messages. This is the next label for either case. 412 } deriving Show 413 414defaultUnknownMap :: TypeMap 415defaultUnknownMap = TypeMap M.empty M.empty 0 416 417-- | How critical the issue is 418data Level = Error | Warning deriving Show 419 420-- | Extract nested error messages from wrapper errors 421unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage 422unwrapErrorMessage (ErrorMessage _ se) = se 423 424replaceUnknowns :: SourceType -> State TypeMap SourceType 425replaceUnknowns = everywhereOnTypesM replaceTypes where 426 replaceTypes :: SourceType -> State TypeMap SourceType 427 replaceTypes (TUnknown ann u) = do 428 m <- get 429 case M.lookup u (umUnknownMap m) of 430 Nothing -> do 431 let u' = umNextIndex m 432 put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 } 433 return (TUnknown ann u') 434 Just u' -> return (TUnknown ann u') 435 replaceTypes (Skolem ann name mbK s sko) = do 436 m <- get 437 case M.lookup s (umSkolemMap m) of 438 Nothing -> do 439 let s' = umNextIndex m 440 put $ m { umSkolemMap = M.insert s (T.unpack name, s', Just (fst ann)) (umSkolemMap m), umNextIndex = s' + 1 } 441 return (Skolem ann name mbK s' sko) 442 Just (_, s', _) -> return (Skolem ann name mbK s' sko) 443 replaceTypes other = return other 444 445onTypesInErrorMessage :: (SourceType -> SourceType) -> ErrorMessage -> ErrorMessage 446onTypesInErrorMessage f = runIdentity . onTypesInErrorMessageM (Identity . f) 447 448onTypesInErrorMessageM :: Applicative m => (SourceType -> m SourceType) -> ErrorMessage -> m ErrorMessage 449onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple 450 where 451 gSimple (InfiniteType t) = InfiniteType <$> f t 452 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2 453 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 454 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t 455 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t 456 gSimple (NoInstanceFound con unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure unks 457 gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us 458 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverse $ bitraverse f pure) insts 459 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts 460 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts 461 gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts 462 gSimple (MissingNewtypeSuperclassInstance cl1 cl2 ts) = MissingNewtypeSuperclassInstance cl1 cl2 <$> traverse f ts 463 gSimple (UnverifiableSuperclassInstance cl1 cl2 ts) = UnverifiableSuperclassInstance cl1 cl2 <$> traverse f ts 464 gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n 465 gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty 466 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k 467 gSimple (OrphanInstance nm cl noms ts) = OrphanInstance nm cl noms <$> traverse f ts 468 gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx 469 gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> traverse (onTypeSearchTypesM f) env 470 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty 471 gSimple (MissingKindDeclaration sig nm ty) = MissingKindDeclaration sig nm <$> f ty 472 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty 473 gSimple (InvalidCoercibleInstanceDeclaration tys) = InvalidCoercibleInstanceDeclaration <$> traverse f tys 474 gSimple other = pure other 475 476 gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 477 gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2 478 gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t 479 gHint (ErrorCheckingKind t k) = ErrorCheckingKind <$> f t <*> f k 480 gHint (ErrorInferringKind t) = ErrorInferringKind <$> f t 481 gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2 482 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts 483 gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con 484 gHint other = pure other 485 486errorDocUri :: ErrorMessage -> Text 487errorDocUri e = "https://github.com/purescript/documentation/blob/master/errors/" <> errorCode e <> ".md" 488 489-- TODO Other possible suggestions: 490-- WildcardInferredType - source span not small enough 491-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert 492errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion 493errorSuggestion err = 494 case err of 495 UnusedImport{} -> emptySuggestion 496 DuplicateImport{} -> emptySuggestion 497 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual 498 UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual 499 UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual 500 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing 501 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) 502 ImplicitQualifiedImportReExport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) 503 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing 504 MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedTypeSimplified ty) <> "\n" 505 MissingKindDeclaration sig name ty -> suggest $ prettyPrintKindSignatureFor sig <> " " <> runProperName name <> " :: " <> T.pack (prettyPrintSuggestedTypeSimplified ty) <> "\n" 506 WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedTypeSimplified ty) 507 WarningParsingCSTModule pe -> do 508 let toks = CST.errToks pe 509 case CST.errType pe of 510 CST.WarnDeprecatedRowSyntax -> do 511 let kind = CST.printTokens $ drop 1 toks 512 sugg | " " `T.isPrefixOf` kind = "Row" <> kind 513 | otherwise = "Row " <> kind 514 suggest sugg 515 CST.WarnDeprecatedForeignKindSyntax -> suggest $ "data " <> CST.printTokens (drop 3 toks) 516 CST.WarnDeprecatedConstraintInForeignImportSyntax -> Nothing 517 CST.WarnDeprecatedKindImportSyntax -> suggest $ CST.printTokens $ drop 1 toks 518 CST.WarnDeprecatedKindExportSyntax -> suggest $ CST.printTokens $ drop 1 toks 519 _ -> Nothing 520 where 521 emptySuggestion = Just $ ErrorSuggestion "" 522 suggest = Just . ErrorSuggestion 523 524 importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text 525 importSuggestion mn refs qual = 526 "import " <> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" <> qstr qual 527 528 qstr :: Maybe ModuleName -> Text 529 qstr (Just mn) = " as " <> runModuleName mn 530 qstr Nothing = "" 531 532suggestionSpan :: ErrorMessage -> Maybe SourceSpan 533suggestionSpan e = 534 -- The `NEL.head` is a bit arbitrary here, but I don't think we'll 535 -- have errors-with-suggestions that also have multiple source 536 -- spans. -garyb 537 getSpan (unwrapErrorMessage e) . NEL.head <$> errorSpan e 538 where 539 startOnly SourceSpan{spanName, spanStart} = SourceSpan {spanName, spanStart, spanEnd = spanStart} 540 541 getSpan simple ss = 542 case simple of 543 MissingTypeDeclaration{} -> startOnly ss 544 MissingKindDeclaration{} -> startOnly ss 545 _ -> ss 546 547showSuggestion :: SimpleErrorMessage -> Text 548showSuggestion suggestion = case errorSuggestion suggestion of 549 Just (ErrorSuggestion x) -> x 550 _ -> "" 551 552ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String 553ansiColor (intensity, color) = 554 ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intensity color] 555 556ansiColorReset :: String 557ansiColorReset = 558 ANSI.setSGRCode [ANSI.Reset] 559 560colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Text -> Text 561colorCode codeColor code = case codeColor of 562 Nothing -> code 563 Just cc -> T.pack (ansiColor cc) <> code <> T.pack ansiColorReset 564 565colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box 566colorCodeBox codeColor b = case codeColor of 567 Nothing -> b 568 Just cc 569 | Box.rows b == 1 -> 570 Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset 571 572 | otherwise -> Box.hcat Box.left -- making two boxes, one for each side of the box so that it will set each row it's own color and will reset it afterwards 573 [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc 574 , b 575 , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset 576 ] 577 578 579-- | Default color intensity and color for code 580defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color) 581defaultCodeColor = (ANSI.Dull, ANSI.Yellow) 582 583-- | `prettyPrintSingleError` Options 584data PPEOptions = PPEOptions 585 { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not 586 , ppeFull :: Bool -- ^ Should write a full error message? 587 , ppeLevel :: Level -- ^ Should this report an error or a warning? 588 , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page? 589 , ppeRelativeDirectory :: FilePath -- ^ FilePath to which the errors are relative 590 } 591 592-- | Default options for PPEOptions 593defaultPPEOptions :: PPEOptions 594defaultPPEOptions = PPEOptions 595 { ppeCodeColor = Just defaultCodeColor 596 , ppeFull = False 597 , ppeLevel = Error 598 , ppeShowDocs = True 599 , ppeRelativeDirectory = mempty 600 } 601 602-- | Pretty print a single error, simplifying if necessary 603prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box 604prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = flip evalState defaultUnknownMap $ do 605 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) 606 um <- get 607 return (prettyPrintErrorMessage um em) 608 where 609 (markCode, markCodeBox) = (colorCode &&& colorCodeBox) codeColor 610 611 -- Pretty print an ErrorMessage 612 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box 613 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) = 614 paras $ 615 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints 616 ] ++ 617 maybe [] (return . Box.moveDown 1) typeInformation ++ 618 [ Box.moveDown 1 $ paras 619 [ line $ "See " <> errorDocUri e <> " for more information, " 620 , line $ "or to contribute content related to this " <> levelText <> "." 621 ] 622 | showDocs 623 ] 624 where 625 typeInformation :: Maybe Box.Box 626 typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ] 627 | otherwise = Nothing 628 where 629 types :: [Box.Box] 630 types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++ 631 map unknownInfo (M.elems (umUnknownMap typeMap)) 632 633 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box 634 skolemInfo (name, s, ss) = 635 paras $ 636 line (markCode (T.pack (name <> show s)) <> " is a rigid type variable") 637 : foldMap (return . line . (" bound at " <>) . displayStartEndPos) ss 638 639 unknownInfo :: Int -> Box.Box 640 unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type" 641 642 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box 643 renderSimpleErrorMessage (InternalCompilerError ctx err) = 644 paras [ line "Internal compiler error:" 645 , indent $ line err 646 , line ctx 647 , line "Please report this at https://github.com/purescript/purescript/issues" 648 ] 649 renderSimpleErrorMessage (ModuleNotFound mn) = 650 paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found." 651 , line $ 652 if isBuiltinModuleName mn 653 then 654 "Module names in the Prim namespace are reserved for built-in modules, but this version of the compiler does not provide module " <> markCode (runModuleName mn) <> ". You may be able to fix this by updating your compiler to a newer version." 655 else 656 "Make sure the source file exists, and that it has been provided as an input to the compiler." 657 ] 658 renderSimpleErrorMessage (FileIOError doWhat err) = 659 paras [ line $ "I/O error while trying to " <> doWhat 660 , indent . lineS $ displayException err 661 ] 662 renderSimpleErrorMessage (ErrorParsingFFIModule path extra) = 663 paras $ [ line "Unable to parse foreign module:" 664 , indent . lineS $ path 665 ] ++ 666 map (indent . lineS) (concatMap Bundle.printErrorMessage (maybeToList extra)) 667 renderSimpleErrorMessage (ErrorParsingModule err) = 668 paras [ line "Unable to parse module: " 669 , prettyPrintParseError err 670 ] 671 renderSimpleErrorMessage (ErrorParsingCSTModule err) = 672 paras [ line "Unable to parse module: " 673 , line $ T.pack $ CST.prettyPrintErrorMessage err 674 ] 675 renderSimpleErrorMessage (WarningParsingCSTModule err) = 676 paras [ line $ T.pack $ CST.prettyPrintWarningMessage err 677 ] 678 renderSimpleErrorMessage (MissingFFIModule mn) = 679 line $ "The foreign module implementation for module " <> markCode (runModuleName mn) <> " is missing." 680 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = 681 paras [ line $ "An unnecessary foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": " 682 , indent . lineS $ path 683 , line $ "Module " <> markCode (runModuleName mn) <> " does not contain any foreign import declarations, so a foreign module is not necessary." 684 ] 685 renderSimpleErrorMessage (MissingFFIImplementations mn idents) = 686 paras [ line $ "The following values are not defined in the foreign module for module " <> markCode (runModuleName mn) <> ": " 687 , indent . paras $ map (line . runIdent) idents 688 ] 689 renderSimpleErrorMessage (UnusedFFIImplementations mn idents) = 690 paras [ line $ "The following definitions in the foreign module for module " <> markCode (runModuleName mn) <> " are unused: " 691 , indent . paras $ map (line . runIdent) idents 692 ] 693 renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) = 694 paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" 695 , indent . paras $ 696 [ line $ "The identifier " <> markCode ident <> " is not valid in PureScript." 697 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers." 698 ] 699 ] 700 renderSimpleErrorMessage (DeprecatedFFIPrime mn ident) = 701 paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" 702 , indent . paras $ 703 [ line $ "The identifier " <> markCode ident <> " contains a prime (" <> markCode "'" <> ")." 704 , line "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future." 705 ] 706 ] 707 renderSimpleErrorMessage InvalidDoBind = 708 line "The last statement in a 'do' block must be an expression, but this block ends with a binder." 709 renderSimpleErrorMessage InvalidDoLet = 710 line "The last statement in a 'do' block must be an expression, but this block ends with a let binding." 711 renderSimpleErrorMessage OverlappingNamesInLet = 712 line "The same name was used more than once in a let binding." 713 renderSimpleErrorMessage (InfiniteType ty) = 714 paras [ line "An infinite type was inferred for an expression: " 715 , markCodeBox $ indent $ prettyType ty 716 ] 717 renderSimpleErrorMessage (InfiniteKind ki) = 718 paras [ line "An infinite kind was inferred for a type: " 719 , markCodeBox $ indent $ prettyType ki 720 ] 721 renderSimpleErrorMessage (MultipleValueOpFixities op) = 722 line $ "There are multiple fixity/precedence declarations for operator " <> markCode (showOp op) 723 renderSimpleErrorMessage (MultipleTypeOpFixities op) = 724 line $ "There are multiple fixity/precedence declarations for type operator " <> markCode (showOp op) 725 renderSimpleErrorMessage (OrphanTypeDeclaration nm) = 726 line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition." 727 renderSimpleErrorMessage (OrphanKindDeclaration nm) = 728 line $ "The kind declaration for " <> markCode (runProperName nm) <> " should be followed by its definition." 729 renderSimpleErrorMessage (OrphanRoleDeclaration nm) = 730 line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." 731 renderSimpleErrorMessage (RedefinedIdent name) = 732 line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" 733 renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = 734 line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" 735 renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i == C.negate = 736 line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" 737 renderSimpleErrorMessage (UnknownName name) = 738 line $ "Unknown " <> printName name 739 renderSimpleErrorMessage (UnknownImport mn name) = 740 paras [ line $ "Cannot import " <> printName (Qualified Nothing name) <> " from module " <> markCode (runModuleName mn) 741 , line "It either does not exist or the module does not export it." 742 ] 743 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = 744 line $ "Module " <> runModuleName mn <> " does not export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) 745 renderSimpleErrorMessage (UnknownExport name) = 746 line $ "Cannot export unknown " <> printName (Qualified Nothing name) 747 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = 748 line $ "Cannot export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) <> ", as it has not been declared." 749 renderSimpleErrorMessage (ScopeConflict nm ms) = 750 paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following modules:" 751 , indent $ paras $ map (line . markCode . runModuleName) ms 752 ] 753 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = 754 paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following open imports:" 755 , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms 756 , line $ "These will be ignored and the " <> case exmn of 757 Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used." 758 Nothing -> "local declaration will be used." 759 ] 760 renderSimpleErrorMessage (DeclConflict new existing) = 761 line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name." 762 renderSimpleErrorMessage (ExportConflict new existing) = 763 line $ "Export for " <> printName new <> " conflicts with " <> printName existing 764 renderSimpleErrorMessage (DuplicateModule mn) = 765 line $ "Module " <> markCode (runModuleName mn) <> " has been defined multiple times" 766 renderSimpleErrorMessage (DuplicateTypeClass pn ss) = 767 paras [ line ("Type class " <> markCode (runProperName pn) <> " has been defined multiple times:") 768 , indent $ line $ displaySourceSpan relPath ss 769 ] 770 renderSimpleErrorMessage (DuplicateInstance pn ss) = 771 paras [ line ("Instance " <> markCode (showIdent pn) <> " has been defined multiple times:") 772 , indent $ line $ displaySourceSpan relPath ss 773 ] 774 renderSimpleErrorMessage (CycleInDeclaration nm) = 775 line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." 776 renderSimpleErrorMessage (CycleInModules mns) = 777 case mns of 778 mn :| [] -> 779 line $ "Module " <> markCode (runModuleName mn) <> " imports itself." 780 _ -> 781 paras [ line "There is a cycle in module dependencies in these modules: " 782 , indent $ paras (line . markCode . runModuleName <$> NEL.toList mns) 783 ] 784 renderSimpleErrorMessage (CycleInTypeSynonym names) = 785 paras $ cycleError <> 786 [ line "Cycles are disallowed because they can lead to loops in the type checker." 787 , line "Consider using a 'newtype' instead." 788 ] 789 where 790 cycleError = case names of 791 pn :| [] -> pure . line $ "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) 792 _ -> [ line " A cycle appears in a set of type synonym definitions:" 793 , indent $ line $ "{" <> T.intercalate ", " (markCode . runProperName <$> NEL.toList names) <> "}" 794 ] 795 renderSimpleErrorMessage (CycleInTypeClassDeclaration (name :| [])) = 796 paras [ line $ "A type class '" <> markCode (runProperName (disqualify name)) <> "' may not have itself as a superclass." ] 797 renderSimpleErrorMessage (CycleInTypeClassDeclaration names) = 798 paras [ line "A cycle appears in a set of type class definitions:" 799 , indent $ line $ "{" <> T.intercalate ", " (markCode . runProperName . disqualify <$> NEL.toList names) <> "}" 800 , line "Cycles are disallowed because they can lead to loops in the type checker." 801 ] 802 renderSimpleErrorMessage (CycleInKindDeclaration (name :| [])) = 803 paras [ line $ "A kind declaration '" <> markCode (runProperName (disqualify name)) <> "' may not refer to itself in its own signature." ] 804 renderSimpleErrorMessage (CycleInKindDeclaration names) = 805 paras [ line "A cycle appears in a set of kind declarations:" 806 , indent $ line $ "{" <> T.intercalate ", " (markCode . runProperName . disqualify <$> NEL.toList names) <> "}" 807 , line "Kind declarations may not refer to themselves in their own signatures." 808 ] 809 renderSimpleErrorMessage (NameIsUndefined ident) = 810 line $ "Value " <> markCode (showIdent ident) <> " is undefined." 811 renderSimpleErrorMessage (UndefinedTypeVariable name) = 812 line $ "Type variable " <> markCode (runProperName name) <> " is undefined." 813 renderSimpleErrorMessage (PartiallyAppliedSynonym name) = 814 paras [ line $ "Type synonym " <> markCode (showQualified runProperName name) <> " is partially applied." 815 , line "Type synonyms must be applied to all of their type arguments." 816 ] 817 renderSimpleErrorMessage (EscapedSkolem name Nothing ty) = 818 paras [ line $ "The type variable " <> markCode name <> " has escaped its scope, appearing in the type" 819 , markCodeBox $ indent $ prettyType ty 820 ] 821 renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) = 822 paras [ line $ "The type variable " <> markCode name <> ", bound at" 823 , indent $ line $ displaySourceSpan relPath srcSpan 824 , line "has escaped its scope, appearing in the type" 825 , markCodeBox $ indent $ prettyType ty 826 ] 827 renderSimpleErrorMessage (TypesDoNotUnify u1 u2) 828 = let (row1Box, row2Box) = printRows u1 u2 829 830 in paras [ line "Could not match type" 831 , row1Box 832 , line "with type" 833 , row2Box 834 ] 835 836 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = 837 paras [ line "Could not match kind" 838 , markCodeBox $ indent $ prettyType k1 839 , line "with kind" 840 , markCodeBox $ indent $ prettyType k2 841 ] 842 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = 843 paras [ line "Could not match constrained type" 844 , markCodeBox $ indent $ prettyType t1 845 , line "with type" 846 , markCodeBox $ indent $ prettyType t2 847 ] 848 renderSimpleErrorMessage (OverlappingInstances _ _ []) = internalError "OverlappingInstances: empty instance list" 849 renderSimpleErrorMessage (OverlappingInstances nm ts ds) = 850 paras [ line "Overlapping type class instances found for" 851 , markCodeBox $ indent $ Box.hsep 1 Box.left 852 [ line (showQualified runProperName nm) 853 , Box.vcat Box.left (map prettyTypeAtom ts) 854 ] 855 , line "The following instances were found:" 856 , indent $ paras (map prettyInstanceName ds) 857 ] 858 renderSimpleErrorMessage (UnknownClass nm) = 859 paras [ line "No type class instance was found for class" 860 , markCodeBox $ indent $ line (showQualified runProperName nm) 861 , line "because the class was not in scope. Perhaps it was not exported." 862 ] 863 renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _) | Just box <- toTypelevelString ty = 864 paras [ line "A custom type error occurred while solving type class constraints:" 865 , indent box 866 ] 867 renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial 868 _ 869 _ 870 (Just (PartialConstraintData bs b))) _) = 871 paras [ line "A case expression could not be determined to cover all inputs." 872 , line "The following additional cases are required to cover all inputs:" 873 , indent $ paras $ 874 Box.hsep 1 Box.left 875 (map (paras . map (line . markCode)) (transpose bs)) 876 : [line "..." | not b] 877 , line "Alternatively, add a Partial constraint to the type of the enclosing value." 878 ] 879 renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _) = 880 paras [ line "A result of type" 881 , markCodeBox $ indent $ prettyType ty 882 , line "was implicitly discarded in a do notation block." 883 , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") 884 ] 885 renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) unks) = 886 paras [ line "No type class instance was found for" 887 , markCodeBox $ indent $ Box.hsep 1 Box.left 888 [ line (showQualified runProperName nm) 889 , Box.vcat Box.left (map prettyTypeAtom ts) 890 ] 891 , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." 892 | unks 893 ] 894 ] 895 renderSimpleErrorMessage (AmbiguousTypeVariables t us) = 896 paras [ line "The inferred type" 897 , markCodeBox $ indent $ prettyType t 898 , line "has type variables which are not determined by those mentioned in the body of the type:" 899 , indent $ Box.hsep 1 Box.left 900 [ Box.vcat Box.left 901 [ line $ markCode ("t" <> T.pack (show u)) <> " could not be determined" 902 | u <- us ] 903 ] 904 , line "Consider adding a type annotation." 905 ] 906 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = 907 paras [ line "Type class instance for" 908 , markCodeBox $ indent $ Box.hsep 1 Box.left 909 [ line (showQualified runProperName nm) 910 , Box.vcat Box.left (map prettyTypeAtom ts) 911 ] 912 , line "is possibly infinite." 913 ] 914 renderSimpleErrorMessage PossiblyInfiniteCoercibleInstance = 915 line $ "A " <> markCode "Coercible" <> " instance is possibly infinite." 916 renderSimpleErrorMessage (CannotDerive nm ts) = 917 paras [ line "Cannot derive a type class instance for" 918 , markCodeBox $ indent $ Box.hsep 1 Box.left 919 [ line (showQualified runProperName nm) 920 , Box.vcat Box.left (map prettyTypeAtom ts) 921 ] 922 , line "since instances of this type class are not derivable." 923 ] 924 renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) = 925 paras [ line "Cannot derive newtype instance for" 926 , markCodeBox $ indent $ Box.hsep 1 Box.left 927 [ line (showQualified runProperName nm) 928 , Box.vcat Box.left (map prettyTypeAtom ts) 929 ] 930 , line "Make sure this is a newtype." 931 ] 932 renderSimpleErrorMessage (MissingNewtypeSuperclassInstance su cl ts) = 933 paras [ line "The derived newtype instance for" 934 , markCodeBox $ indent $ Box.hsep 1 Box.left 935 [ line (showQualified runProperName cl) 936 , Box.vcat Box.left (map prettyTypeAtom ts) 937 ] 938 , line $ "does not include a derived superclass instance for " <> markCode (showQualified runProperName su) <> "." 939 ] 940 renderSimpleErrorMessage (UnverifiableSuperclassInstance su cl ts) = 941 paras [ line "The derived newtype instance for" 942 , markCodeBox $ indent $ Box.hsep 1 Box.left 943 [ line (showQualified runProperName cl) 944 , Box.vcat Box.left (map prettyTypeAtom ts) 945 ] 946 , line $ "implies an superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified." 947 ] 948 renderSimpleErrorMessage (InvalidDerivedInstance nm ts argCount) = 949 paras [ line "Cannot derive the type class instance" 950 , markCodeBox $ indent $ Box.hsep 1 Box.left 951 [ line (showQualified runProperName nm) 952 , Box.vcat Box.left (map prettyTypeAtom ts) 953 ] 954 , line $ fold 955 [ "because the " 956 , markCode (showQualified runProperName nm) 957 , " type class has " 958 , T.pack (show argCount) 959 , " type " 960 , if argCount == 1 then "argument" else "arguments" 961 , ", but the declaration specifies " <> T.pack (show (length ts)) <> "." 962 ] 963 ] 964 renderSimpleErrorMessage (ExpectedTypeConstructor nm ts ty) = 965 paras [ line "Cannot derive the type class instance" 966 , markCodeBox $ indent $ Box.hsep 1 Box.left 967 [ line (showQualified runProperName nm) 968 , Box.vcat Box.left (map prettyTypeAtom ts) 969 ] 970 , "because the type" 971 , markCodeBox $ indent $ prettyType ty 972 , line "is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module." 973 ] 974 renderSimpleErrorMessage (CannotFindDerivingType nm) = 975 line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found." 976 renderSimpleErrorMessage (DuplicateLabel l expr) = 977 paras $ [ line $ "Label " <> markCode (prettyPrintLabel l) <> " appears more than once in a row type." ] 978 <> foldMap (\expr' -> [ line "Relevant expression: " 979 , markCodeBox $ indent $ prettyPrintValue prettyDepth expr' 980 ]) expr 981 renderSimpleErrorMessage (DuplicateTypeArgument name) = 982 line $ "Type argument " <> markCode name <> " appears more than once." 983 renderSimpleErrorMessage (DuplicateValueDeclaration nm) = 984 line $ "Multiple value declarations exist for " <> markCode (showIdent nm) <> "." 985 renderSimpleErrorMessage (ArgListLengthsDiffer ident) = 986 line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident) 987 renderSimpleErrorMessage (OverlappingArgNames ident) = 988 line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident 989 renderSimpleErrorMessage (MissingClassMember identsAndTypes) = 990 paras [ line "The following type class members have not been implemented:" 991 , Box.vcat Box.left 992 [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> prettyType ty 993 | (ident, ty) <- NEL.toList identsAndTypes ] 994 ] 995 renderSimpleErrorMessage (ExtraneousClassMember ident className) = 996 line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) 997 renderSimpleErrorMessage (ExpectedType ty kind) = 998 paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode C.typ <> "." 999 , line "The error arises from the type" 1000 , markCodeBox $ indent $ prettyType ty 1001 , line "having the kind" 1002 , markCodeBox $ indent $ prettyType kind 1003 , line "instead." 1004 ] 1005 renderSimpleErrorMessage (IncorrectConstructorArity nm expected actual) = 1006 paras [ line $ "Data constructor " <> markCode (showQualified runProperName nm) <> " was given " <> T.pack (show actual) <> " arguments in a case expression, but expected " <> T.pack (show expected) <> " arguments." 1007 , line $ "This problem can be fixed by giving " <> markCode (showQualified runProperName nm) <> " " <> T.pack (show expected) <> " arguments." 1008 ] 1009 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = 1010 paras [ line "Expression" 1011 , markCodeBox $ indent $ prettyPrintValue prettyDepth expr 1012 , line "does not have type" 1013 , markCodeBox $ indent $ prettyType ty 1014 ] 1015 renderSimpleErrorMessage (PropertyIsMissing prop) = 1016 line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "." 1017 renderSimpleErrorMessage (AdditionalProperty prop) = 1018 line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "." 1019 renderSimpleErrorMessage (OrphanInstance nm cnm nonOrphanModules ts) = 1020 paras [ line $ "Orphan instance" <> prettyPrintPlainIdent nm <> " found for " 1021 , markCodeBox $ indent $ Box.hsep 1 Box.left 1022 [ line (showQualified runProperName cnm) 1023 , Box.vcat Box.left (map prettyTypeAtom ts) 1024 ] 1025 , Box.vcat Box.left $ case modulesToList of 1026 [] -> [ line "There is nowhere this instance can be placed without being an orphan." 1027 , line "A newtype wrapper can be used to avoid this problem." 1028 ] 1029 _ -> [ Box.text $ "This problem can be resolved by declaring the instance in " 1030 <> T.unpack formattedModules 1031 <> ", or by defining the instance on a newtype wrapper." 1032 ] 1033 ] 1034 where 1035 modulesToList = S.toList $ S.delete (moduleNameFromString "Prim") nonOrphanModules 1036 formattedModules = T.intercalate " or " (markCode . runModuleName <$> modulesToList) 1037 renderSimpleErrorMessage (InvalidNewtype name) = 1038 paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid." 1039 , line "Newtypes must define a single constructor with a single argument." 1040 ] 1041 renderSimpleErrorMessage (InvalidInstanceHead ty) = 1042 paras [ line "Type class instance head is invalid due to use of type" 1043 , markCodeBox $ indent $ prettyType ty 1044 , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies." 1045 ] 1046 renderSimpleErrorMessage (TransitiveExportError x ys) = 1047 paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following to also be exported: " 1048 , indent $ paras $ map (line . markCode . prettyPrintExport) ys 1049 ] 1050 renderSimpleErrorMessage (TransitiveDctorExportError x ctors) = 1051 paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following data constructor" <> (if length ctors == 1 then "" else "s") <> " to also be exported: " 1052 , indent $ paras $ map (line . markCode . runProperName) ctors 1053 ] 1054 renderSimpleErrorMessage (HiddenConstructors x className) = 1055 paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " hides data constructors but the type declares an instance of " <> markCode (showQualified runProperName className) <> "." 1056 , line "Such instance allows to match and construct values of this type, effectively making the constructors public." 1057 ] 1058 renderSimpleErrorMessage (ShadowedName nm) = 1059 line $ "Name " <> markCode (showIdent nm) <> " was shadowed." 1060 renderSimpleErrorMessage (ShadowedTypeVar tv) = 1061 line $ "Type variable " <> markCode tv <> " was shadowed." 1062 renderSimpleErrorMessage (UnusedName nm) = 1063 line $ "Name " <> markCode (showIdent nm) <> " was introduced but not used." 1064 renderSimpleErrorMessage (UnusedDeclaration nm) = 1065 line $ "Declaration " <> markCode (showIdent nm) <> " was not used, and is not exported." 1066 renderSimpleErrorMessage (UnusedTypeVar tv) = 1067 line $ "Type variable " <> markCode tv <> " is ambiguous, since it is unused in the polymorphic type which introduces it." 1068 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = 1069 line $ "Importing type " <> markCode (runProperName name <> "(..)") <> " from " <> markCode (runModuleName mn) <> " is misleading as it has no exported data constructors." 1070 renderSimpleErrorMessage (ImportHidingModule name) = 1071 paras [ line "hiding imports cannot be used to hide modules." 1072 , line $ "An attempt was made to hide the import of " <> markCode (runModuleName name) 1073 ] 1074 renderSimpleErrorMessage (WildcardInferredType ty ctx) = 1075 paras $ [ line "Wildcard type definition has the inferred type " 1076 , markCodeBox $ indent $ prettyType ty 1077 ] <> renderContext ctx 1078 renderSimpleErrorMessage (HoleInferredType name ty ctx ts) = 1079 let 1080 maxTSResults = 15 1081 tsResult = case ts of 1082 Just TSAfter{tsAfterIdentifiers=idents} | not (null idents) -> 1083 let 1084 formatTS (names, types) = 1085 let 1086 idBoxes = Box.text . T.unpack . showQualified id <$> names 1087 tyBoxes = (\t -> BoxHelpers.indented 1088 (Box.text ":: " Box.<> prettyType t)) <$> types 1089 longestId = maximum (map Box.cols idBoxes) 1090 in 1091 Box.vcat Box.top $ 1092 zipWith (Box.<>) 1093 (Box.alignHoriz Box.left longestId <$> idBoxes) 1094 tyBoxes 1095 in [ line "You could substitute the hole with one of these values:" 1096 , markCodeBox (indent (formatTS (unzip (take maxTSResults idents)))) 1097 ] 1098 _ -> [] 1099 in 1100 paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type " 1101 , markCodeBox (indent (prettyTypeWithDepth maxBound ty)) 1102 ] ++ tsResult ++ renderContext ctx 1103 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = 1104 paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "." 1105 , line "It is good practice to provide type declarations as a form of documentation." 1106 , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" 1107 , markCodeBox $ indent $ prettyTypeWithDepth maxBound ty 1108 ] 1109 renderSimpleErrorMessage (MissingKindDeclaration sig name ty) = 1110 let sigKw = prettyPrintKindSignatureFor sig in 1111 paras [ line $ "The inferred kind for the " <> sigKw <> " declaration " <> markCode (runProperName name) <> " contains polymorphic kinds." 1112 , line "Consider adding a top-level kind signature as a form of documentation." 1113 , markCodeBox $ indent $ Box.hsep 1 Box.left 1114 [ line $ sigKw <> " " <> runProperName name <> " ::" 1115 , prettyTypeWithDepth maxBound ty 1116 ] 1117 ] 1118 renderSimpleErrorMessage (OverlappingPattern bs b) = 1119 paras $ [ line "A case expression contains unreachable cases:\n" 1120 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) 1121 ] ++ 1122 [ line "..." | not b ] 1123 renderSimpleErrorMessage IncompleteExhaustivityCheck = 1124 paras [ line "An exhaustivity check was abandoned due to too many possible cases." 1125 , line "You may want to decompose your data types into smaller types." 1126 ] 1127 1128 renderSimpleErrorMessage (UnusedImport mn qualifier) = 1129 let 1130 mark = markCode . runModuleName 1131 unqualified = "The import of " <> mark mn <> " is redundant" 1132 msg' q = "The qualified import of " <> mark mn <> " as " <> mark q <> " is redundant" 1133 msg = maybe unqualified msg' 1134 in line $ msg qualifier 1135 1136 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = 1137 paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:" 1138 , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names 1139 , line "It could be replaced with:" 1140 , indent $ line $ markCode $ showSuggestion msg ] 1141 1142 renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) = 1143 paras [line $ "The import of type " <> markCode (runProperName name) 1144 <> " from module " <> markCode (runModuleName mn) <> " includes data constructors but only the type is used" 1145 , line "It could be replaced with:" 1146 , indent $ line $ markCode $ showSuggestion msg ] 1147 1148 renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) = 1149 paras [ line $ "The import of type " <> markCode (runProperName name) 1150 <> " from module " <> markCode (runModuleName mn) <> " includes the following unused data constructors:" 1151 , indent $ paras $ map (line . markCode . runProperName) names 1152 , line "It could be replaced with:" 1153 , indent $ line $ markCode $ showSuggestion msg ] 1154 1155 renderSimpleErrorMessage (DuplicateSelectiveImport name) = 1156 line $ "There is an existing import of " <> markCode (runModuleName name) <> ", consider merging the import lists" 1157 1158 renderSimpleErrorMessage (DuplicateImport name imp qual) = 1159 line $ "Duplicate import of " <> markCode (prettyPrintImport name imp qual) 1160 1161 renderSimpleErrorMessage (DuplicateImportRef name) = 1162 line $ "Import list contains multiple references to " <> printName (Qualified Nothing name) 1163 1164 renderSimpleErrorMessage (DuplicateExportRef name) = 1165 line $ "Export list contains multiple references to " <> printName (Qualified Nothing name) 1166 1167 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = 1168 paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend." 1169 , line $ "Acceptable values fall within the range " <> markCode (T.pack (show lo)) <> " to " <> markCode (T.pack (show hi)) <> " (inclusive)." ] 1170 1171 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) = 1172 paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports." 1173 , line $ "As there are multiple modules being imported as " <> markCode (runModuleName asModule) <> ", consider using the explicit form:" 1174 , indent $ line $ markCode $ showSuggestion msg 1175 ] 1176 renderSimpleErrorMessage msg@(ImplicitQualifiedImportReExport importedModule asModule _) = 1177 paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports." 1178 , line "As this module is being re-exported, consider using the explicit form:" 1179 , indent $ line $ markCode $ showSuggestion msg 1180 ] 1181 1182 renderSimpleErrorMessage msg@(ImplicitImport mn _) = 1183 paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the explicit form: " 1184 , indent $ line $ markCode $ showSuggestion msg 1185 ] 1186 1187 renderSimpleErrorMessage msg@(HidingImport mn _) = 1188 paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the inclusive form: " 1189 , indent $ line $ markCode $ showSuggestion msg 1190 ] 1191 1192 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = 1193 paras [ line "Binder list length differs in case alternative:" 1194 , indent $ line $ T.intercalate ", " $ fmap prettyPrintBinderAtom bs 1195 , line $ "Expecting " <> T.pack (show l) <> " binder" <> (if l == 1 then "" else "s") <> "." 1196 ] 1197 1198 renderSimpleErrorMessage IncorrectAnonymousArgument = 1199 line "An anonymous function argument appears in an invalid context." 1200 1201 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = 1202 paras [ line $ "Operator " <> markCode (showQualified showOp op) <> " cannot be used in a pattern as it is an alias for function " <> showQualified showIdent fn <> "." 1203 , line "Only aliases for data constructors may be used in patterns." 1204 ] 1205 1206 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = 1207 paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "." 1208 , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" 1209 , markCodeBox $ indent $ prettyType ty 1210 , line "Try adding a type signature." 1211 ] 1212 1213 renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) = 1214 paras [ line $ "Cannot derive an instance of the " <> markCode "Newtype" <> " class for non-newtype " <> markCode (runProperName tyName) <> "." 1215 ] 1216 1217 renderSimpleErrorMessage (ExpectedWildcard tyName) = 1218 paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "." 1219 ] 1220 1221 renderSimpleErrorMessage (CannotUseBindWithDo name) = 1222 paras [ line $ "The name " <> markCode (showIdent name) <> " cannot be brought into scope in a do notation block, since do notation uses the same name." 1223 ] 1224 1225 renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) = 1226 paras [ line $ "The type class " <> markCode (showQualified runProperName className) <> 1227 " expects " <> T.pack (show expected) <> " " <> argsMsg <> "." 1228 , line $ "But the instance" <> prettyPrintPlainIdent dictName <> mismatchMsg <> T.pack (show actual) <> "." 1229 ] 1230 where 1231 mismatchMsg = if actual > expected then " provided " else " only provided " 1232 argsMsg = if expected > 1 then "arguments" else "argument" 1233 1234 renderSimpleErrorMessage (UserDefinedWarning msgTy) = 1235 let msg = fromMaybe (prettyType msgTy) (toTypelevelString msgTy) in 1236 paras [ line "A custom warning occurred while solving type class constraints:" 1237 , indent msg 1238 ] 1239 1240 renderSimpleErrorMessage (UnusableDeclaration ident unexplained) = 1241 paras $ 1242 [ line $ "The declaration " <> markCode (showIdent ident) <> " contains arguments that couldn't be determined." 1243 ] <> 1244 1245 case unexplained of 1246 [required] -> 1247 [ line $ "These arguments are: { " <> T.intercalate ", " required <> " }" 1248 ] 1249 1250 options -> 1251 [ line "To fix this, one of the following sets of variables must be determined:" 1252 , Box.moveRight 2 . Box.vsep 0 Box.top $ 1253 map (\set -> line $ "{ " <> T.intercalate ", " set <> " }") options 1254 ] 1255 1256 renderSimpleErrorMessage (CannotDefinePrimModules mn) = 1257 paras 1258 [ line $ "The module name " <> markCode (runModuleName mn) <> " is in the Prim namespace." 1259 , line "The Prim namespace is reserved for compiler-defined terms." 1260 ] 1261 1262 renderSimpleErrorMessage (MixedAssociativityError opsWithAssoc) = 1263 paras 1264 [ line "Cannot parse an expression that uses operators of the same precedence but mixed associativity:" 1265 , indent $ paras $ map (\(name, assoc) -> line $ markCode (showQualified showOp name) <> " is " <> markCode (T.pack (showAssoc assoc))) (NEL.toList opsWithAssoc) 1266 , line "Use parentheses to resolve this ambiguity." 1267 ] 1268 1269 renderSimpleErrorMessage (NonAssociativeError ops) = 1270 if NEL.length ops == 1 1271 then 1272 paras 1273 [ line $ "Cannot parse an expression that uses multiple instances of the non-associative operator " <> markCode (showQualified showOp (NEL.head ops)) <> "." 1274 , line "Use parentheses to resolve this ambiguity." 1275 ] 1276 else 1277 paras 1278 [ line "Cannot parse an expression that uses multiple non-associative operators of the same precedence:" 1279 , indent $ paras $ map (line . markCode . showQualified showOp) (NEL.toList ops) 1280 , line "Use parentheses to resolve this ambiguity." 1281 ] 1282 1283 renderSimpleErrorMessage (QuantificationCheckFailureInKind var) = 1284 paras 1285 [ line $ "Cannot generalize the kind of type variable " <> markCode var <> " since it would not be well-scoped." 1286 , line "Try adding a kind annotation." 1287 ] 1288 1289 renderSimpleErrorMessage (QuantificationCheckFailureInType us ty) = 1290 let unks = 1291 fmap (\u -> Box.hsep 1 Box.top [ "where" 1292 , markCodeBox (prettyType (srcTUnknown u)) 1293 , "is an unknown kind." 1294 ]) us 1295 in paras 1296 [ line "Cannot unambiguously generalize kinds appearing in the elaborated type:" 1297 , indent $ markCodeBox $ typeAsBox prettyDepth ty 1298 , paras unks 1299 , line "Try adding additional kind signatures or polymorphic kind variables." 1300 ] 1301 1302 renderSimpleErrorMessage (VisibleQuantificationCheckFailureInType var) = 1303 paras 1304 [ line $ "Visible dependent quantification of type variable " <> markCode var <> " is not supported." 1305 , line "If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre)." 1306 ] 1307 1308 renderSimpleErrorMessage (UnsupportedTypeInKind ty) = 1309 paras 1310 [ line "The type:" 1311 , indent $ markCodeBox $ prettyType ty 1312 , line "is not supported in kinds." 1313 ] 1314 1315 renderSimpleErrorMessage (RoleMismatch var inferred declared) = 1316 paras 1317 [ line $ "Role mismatch for the type parameter " <> markCode var <> ":" 1318 , indent . line $ 1319 "The annotation says " <> markCode (displayRole declared) <> 1320 " but the role " <> markCode (displayRole inferred) <> 1321 " is required." 1322 ] 1323 1324 renderSimpleErrorMessage (InvalidCoercibleInstanceDeclaration tys) = 1325 paras 1326 [ line "Invalid type class instance declaration for" 1327 , markCodeBox $ indent $ Box.hsep 1 Box.left 1328 [ line (showQualified runProperName C.Coercible) 1329 , Box.vcat Box.left (map prettyTypeAtom tys) 1330 ] 1331 , line "Instance declarations of this type class are disallowed." 1332 ] 1333 1334 renderSimpleErrorMessage UnsupportedRoleDeclaration = 1335 line "Role declarations are only supported for data types, not for type synonyms nor type classes." 1336 1337 renderSimpleErrorMessage (RoleDeclarationArityMismatch name expected actual) = 1338 line $ T.intercalate " " 1339 [ "The type" 1340 , markCode (runProperName name) 1341 , "expects" 1342 , T.pack (show expected) 1343 , if expected == 1 then "argument" else "arguments" 1344 , "but its role declaration lists" 1345 <> if actual > expected then "" else " only" 1346 , T.pack (show actual) 1347 , if actual > 1 then "roles" else "role" 1348 ] <> "." 1349 1350 renderSimpleErrorMessage (DuplicateRoleDeclaration name) = 1351 line $ "Duplicate role declaration for " <> markCode (runProperName name) <> "." 1352 1353 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box 1354 renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = 1355 let (row1Box, row2Box) = printRows t1 t2 1356 in paras [ detail 1357 , Box.hsep 1 Box.top [ line "while trying to match type" 1358 , row1Box 1359 ] 1360 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" 1361 , row2Box 1362 ] 1363 ] 1364 renderHint (ErrorUnifyingTypes t1 t2) detail = 1365 paras [ detail 1366 , Box.hsep 1 Box.top [ line "while trying to match type" 1367 , markCodeBox $ typeAsBox prettyDepth t1 1368 ] 1369 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" 1370 , markCodeBox $ typeAsBox prettyDepth t2 1371 ] 1372 ] 1373 renderHint (ErrorInExpression expr) detail = 1374 paras [ detail 1375 , Box.hsep 1 Box.top [ Box.text "in the expression" 1376 , markCodeBox $ markCodeBox $ prettyPrintValue prettyDepth expr 1377 ] 1378 ] 1379 renderHint (ErrorInModule mn) detail = 1380 paras [ line $ "in module " <> markCode (runModuleName mn) 1381 , detail 1382 ] 1383 renderHint (ErrorInSubsumption t1 t2) detail = 1384 paras [ detail 1385 , Box.hsep 1 Box.top [ line "while checking that type" 1386 , markCodeBox $ typeAsBox prettyDepth t1 1387 ] 1388 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type" 1389 , markCodeBox $ typeAsBox prettyDepth t2 1390 ] 1391 ] 1392 renderHint (ErrorInInstance nm ts) detail = 1393 paras [ detail 1394 , line "in type class instance" 1395 , markCodeBox $ indent $ Box.hsep 1 Box.top 1396 [ line $ showQualified runProperName nm 1397 , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) 1398 ] 1399 ] 1400 renderHint (ErrorCheckingKind ty kd) detail = 1401 paras [ detail 1402 , Box.hsep 1 Box.top [ line "while checking that type" 1403 , markCodeBox $ typeAsBox prettyDepth ty 1404 ] 1405 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has kind" 1406 , markCodeBox $ typeAsBox prettyDepth kd 1407 ] 1408 ] 1409 renderHint (ErrorInferringKind ty) detail = 1410 paras [ detail 1411 , Box.hsep 1 Box.top [ line "while inferring the kind of" 1412 , markCodeBox $ typeAsBox prettyDepth ty 1413 ] 1414 ] 1415 renderHint ErrorCheckingGuard detail = 1416 paras [ detail 1417 , line "while checking the type of a guard clause" 1418 ] 1419 renderHint (ErrorInferringType expr) detail = 1420 paras [ detail 1421 , Box.hsep 1 Box.top [ line "while inferring the type of" 1422 , markCodeBox $ prettyPrintValue prettyDepth expr 1423 ] 1424 ] 1425 renderHint (ErrorCheckingType expr ty) detail = 1426 paras [ detail 1427 , Box.hsep 1 Box.top [ line "while checking that expression" 1428 , markCodeBox $ prettyPrintValue prettyDepth expr 1429 ] 1430 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type" 1431 , markCodeBox $ typeAsBox prettyDepth ty 1432 ] 1433 ] 1434 renderHint (ErrorCheckingAccessor expr prop) detail = 1435 paras [ detail 1436 , Box.hsep 1 Box.top [ line "while checking type of property accessor" 1437 , markCodeBox $ prettyPrintValue prettyDepth (Accessor prop expr) 1438 ] 1439 ] 1440 renderHint (ErrorInApplication f t a) detail = 1441 paras [ detail 1442 , Box.hsep 1 Box.top [ line "while applying a function" 1443 , markCodeBox $ prettyPrintValue prettyDepth f 1444 ] 1445 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type" 1446 , markCodeBox $ typeAsBox prettyDepth t 1447 ] 1448 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument" 1449 , markCodeBox $ prettyPrintValue prettyDepth a 1450 ] 1451 ] 1452 renderHint (ErrorInDataConstructor nm) detail = 1453 paras [ detail 1454 , line $ "in data constructor " <> markCode (runProperName nm) 1455 ] 1456 renderHint (ErrorInTypeConstructor nm) detail = 1457 paras [ detail 1458 , line $ "in type constructor " <> markCode (runProperName nm) 1459 ] 1460 renderHint (ErrorInBindingGroup nms) detail = 1461 paras [ detail 1462 , line $ "in binding group " <> T.intercalate ", " (NEL.toList (fmap showIdent nms)) 1463 ] 1464 renderHint (ErrorInDataBindingGroup nms) detail = 1465 paras [ detail 1466 , line $ "in data binding group " <> T.intercalate ", " (map runProperName nms) 1467 ] 1468 renderHint (ErrorInTypeSynonym name) detail = 1469 paras [ detail 1470 , line $ "in type synonym " <> markCode (runProperName name) 1471 ] 1472 renderHint (ErrorInValueDeclaration n) detail = 1473 paras [ detail 1474 , line $ "in value declaration " <> markCode (showIdent n) 1475 ] 1476 renderHint (ErrorInTypeDeclaration n) detail = 1477 paras [ detail 1478 , line $ "in type declaration for " <> markCode (showIdent n) 1479 ] 1480 renderHint (ErrorInTypeClassDeclaration name) detail = 1481 paras [ detail 1482 , line $ "in type class declaration for " <> markCode (runProperName name) 1483 ] 1484 renderHint (ErrorInKindDeclaration name) detail = 1485 paras [ detail 1486 , line $ "in kind declaration for " <> markCode (runProperName name) 1487 ] 1488 renderHint (ErrorInRoleDeclaration name) detail = 1489 paras [ detail 1490 , line $ "in role declaration for " <> markCode (runProperName name) 1491 ] 1492 renderHint (ErrorInForeignImport nm) detail = 1493 paras [ detail 1494 , line $ "in foreign import " <> markCode (showIdent nm) 1495 ] 1496 renderHint (ErrorInForeignImportData nm) detail = 1497 paras [ detail 1498 , line $ "in foreign data type declaration for " <> markCode (runProperName nm) 1499 ] 1500 renderHint (ErrorSolvingConstraint (Constraint _ nm _ ts _)) detail = 1501 paras [ detail 1502 , line "while solving type class constraint" 1503 , markCodeBox $ indent $ Box.hsep 1 Box.left 1504 [ line (showQualified runProperName nm) 1505 , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) 1506 ] 1507 ] 1508 renderHint (MissingConstructorImportForCoercible name) detail = 1509 paras 1510 [ detail 1511 , Box.moveUp 1 $ Box.moveRight 2 $ line $ "Solving this instance requires the newtype constructor " <> markCode (showQualified runProperName name) <> " to be in scope." 1512 ] 1513 renderHint (PositionedError srcSpan) detail = 1514 paras [ line $ "at " <> displaySourceSpan relPath (NEL.head srcSpan) 1515 , detail 1516 ] 1517 1518 printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box 1519 printRow f = markCodeBox . indent . f prettyDepth . 1520 if full then id else eraseForAllKindAnnotations . eraseKindApps 1521 1522 -- If both rows are not empty, print them as diffs 1523 -- If verbose print all rows else only print unique rows 1524 printRows :: Type a -> Type a -> (Box.Box, Box.Box) 1525 printRows r1 r2 = case (full, r1, r2) of 1526 (True, _ , _) -> (printRow typeAsBox r1, printRow typeAsBox r2) 1527 1528 (_, RCons{}, RCons{}) -> 1529 let (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2) 1530 in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2) 1531 1532 (_, _, _) -> (printRow typeAsBox r1, printRow typeAsBox r2) 1533 1534 1535 -- Keep the unique labels only 1536 filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) 1537 filterRows (s1, r1) (s2, r2) = 1538 let sort' = sortOn $ \(RowListItem _ name ty) -> (name, ty) 1539 (unique1, unique2) = diffSortedRowLists (sort' s1, sort' s2) 1540 in ( rowFromList (unique1, r1) 1541 , rowFromList (unique2, r2) 1542 ) 1543 1544 -- Importantly, this removes exactly the same number of elements from 1545 -- both lists, even if there are repeated (name, ty) keys. It requires 1546 -- the inputs to be sorted but ensures that the outputs remain sorted. 1547 diffSortedRowLists :: ([RowListItem a], [RowListItem a]) -> ([RowListItem a], [RowListItem a]) 1548 diffSortedRowLists = go where 1549 go = \case 1550 (s1@(h1@(RowListItem _ name1 ty1) : t1), s2@(h2@(RowListItem _ name2 ty2) : t2)) -> 1551 case (name1, ty1) `compare` (name2, ty2) of 1552 EQ -> go (t1, t2) 1553 LT -> first (h1:) $ go (t1, s2) 1554 GT -> second (h2:) $ go (s1, t2) 1555 other -> other 1556 1557 renderContext :: Context -> [Box.Box] 1558 renderContext [] = [] 1559 renderContext ctx = 1560 [ line "in the following context:" 1561 , indent $ paras 1562 [ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ") 1563 , markCodeBox $ typeAsBox prettyDepth ty' 1564 ] 1565 | (ident, ty') <- take 5 ctx 1566 ] 1567 ] 1568 1569 printName :: Qualified Name -> Text 1570 printName qn = nameType (disqualify qn) <> " " <> markCode (runName qn) 1571 1572 nameType :: Name -> Text 1573 nameType (IdentName _) = "value" 1574 nameType (ValOpName _) = "operator" 1575 nameType (TyName _) = "type" 1576 nameType (TyOpName _) = "type operator" 1577 nameType (DctorName _) = "data constructor" 1578 nameType (TyClassName _) = "type class" 1579 nameType (ModName _) = "module" 1580 1581 runName :: Qualified Name -> Text 1582 runName (Qualified mn (IdentName name)) = 1583 showQualified showIdent (Qualified mn name) 1584 runName (Qualified mn (ValOpName op)) = 1585 showQualified showOp (Qualified mn op) 1586 runName (Qualified mn (TyName name)) = 1587 showQualified runProperName (Qualified mn name) 1588 runName (Qualified mn (TyOpName op)) = 1589 showQualified showOp (Qualified mn op) 1590 runName (Qualified mn (DctorName name)) = 1591 showQualified runProperName (Qualified mn name) 1592 runName (Qualified mn (TyClassName name)) = 1593 showQualified runProperName (Qualified mn name) 1594 runName (Qualified Nothing (ModName name)) = 1595 runModuleName name 1596 runName (Qualified _ ModName{}) = 1597 internalError "qualified ModName in runName" 1598 1599 prettyDepth :: Int 1600 prettyDepth | full = 1000 1601 | otherwise = 3 1602 1603 prettyType :: Type a -> Box.Box 1604 prettyType = prettyTypeWithDepth prettyDepth 1605 1606 prettyTypeWithDepth :: Int -> Type a -> Box.Box 1607 prettyTypeWithDepth depth 1608 | full = typeAsBox depth 1609 | otherwise = typeAsBox depth . eraseForAllKindAnnotations . eraseKindApps 1610 1611 prettyTypeAtom :: Type a -> Box.Box 1612 prettyTypeAtom 1613 | full = typeAtomAsBox prettyDepth 1614 | otherwise = typeAtomAsBox prettyDepth . eraseForAllKindAnnotations . eraseKindApps 1615 1616 levelText :: Text 1617 levelText = case level of 1618 Error -> "error" 1619 Warning -> "warning" 1620 1621 paras :: [Box.Box] -> Box.Box 1622 paras = Box.vcat Box.left 1623 1624 -- | Simplify an error message 1625 simplifyErrorMessage :: ErrorMessage -> ErrorMessage 1626 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple 1627 where 1628 -- Take the last instance of each "hint category" 1629 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint] 1630 simplifyHints = reverse . nubBy categoriesEqual . stripRedundantHints simple . reverse 1631 1632 -- Don't remove hints in the "other" category 1633 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool 1634 categoriesEqual x y = 1635 case (hintCategory x, hintCategory y) of 1636 (OtherHint, _) -> False 1637 (_, OtherHint) -> False 1638 (c1, c2) -> c1 == c2 1639 1640 -- | See https://github.com/purescript/purescript/issues/1802 1641 stripRedundantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint] 1642 stripRedundantHints ExprDoesNotHaveType{} = stripFirst isCheckHint 1643 where 1644 isCheckHint ErrorCheckingType{} = True 1645 isCheckHint _ = False 1646 stripRedundantHints TypesDoNotUnify{} = stripFirst isUnifyHint 1647 where 1648 isUnifyHint ErrorUnifyingTypes{} = True 1649 isUnifyHint _ = False 1650 stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _) = filter (not . isSolverHint) 1651 where 1652 isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' 1653 isSolverHint _ = False 1654 stripRedundantHints NoInstanceFound{} = stripFirst isSolverHint 1655 where 1656 isSolverHint ErrorSolvingConstraint{} = True 1657 isSolverHint _ = False 1658 stripRedundantHints _ = id 1659 1660 stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint] 1661 stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs 1662 stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs 1663 stripFirst p (hint : hs) 1664 | p hint = hs 1665 | otherwise = hint : hs 1666 stripFirst _ [] = [] 1667 1668 hintCategory :: ErrorMessageHint -> HintCategory 1669 hintCategory ErrorCheckingType{} = ExprHint 1670 hintCategory ErrorInferringType{} = ExprHint 1671 hintCategory ErrorInExpression{} = ExprHint 1672 hintCategory ErrorUnifyingTypes{} = CheckHint 1673 hintCategory ErrorInSubsumption{} = CheckHint 1674 hintCategory ErrorInApplication{} = CheckHint 1675 hintCategory ErrorCheckingKind{} = CheckHint 1676 hintCategory ErrorSolvingConstraint{} = SolverHint 1677 hintCategory PositionedError{} = PositionHint 1678 hintCategory _ = OtherHint 1679 1680 prettyPrintPlainIdent :: Ident -> Text 1681 prettyPrintPlainIdent ident = 1682 if isPlainIdent ident 1683 then " " <> markCode (showIdent ident) 1684 else "" 1685 1686 prettyInstanceName :: Qualified (Either SourceType Ident) -> Box.Box 1687 prettyInstanceName = \case 1688 Qualified maybeMn (Left ty) -> 1689 "instance " 1690 Box.<> (case maybeMn of 1691 Just mn -> "in module " 1692 Box.<> line (markCode $ runModuleName mn) 1693 Box.<> " " 1694 Nothing -> Box.nullBox) 1695 Box.<> "with type " 1696 Box.<> markCodeBox (prettyType ty) 1697 Box.<> " " 1698 Box.<> (line . displayStartEndPos . fst $ getAnnForType ty) 1699 Qualified mn (Right inst) -> line . markCode . showQualified showIdent $ Qualified mn inst 1700 1701-- Pretty print and export declaration 1702prettyPrintExport :: DeclarationRef -> Text 1703prettyPrintExport (TypeRef _ pn _) = runProperName pn 1704prettyPrintExport ref = 1705 fromMaybe 1706 (internalError "prettyPrintRef returned Nothing in prettyPrintExport") 1707 (prettyPrintRef ref) 1708 1709prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text 1710prettyPrintImport mn idt qual = 1711 let i = case idt of 1712 Implicit -> runModuleName mn 1713 Explicit refs -> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" 1714 Hiding refs -> runModuleName mn <> " hiding (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" 1715 in i <> maybe "" (\q -> " as " <> runModuleName q) qual 1716 1717prettyPrintRef :: DeclarationRef -> Maybe Text 1718prettyPrintRef (TypeRef _ pn Nothing) = 1719 Just $ runProperName pn <> "(..)" 1720prettyPrintRef (TypeRef _ pn (Just [])) = 1721 Just $ runProperName pn 1722prettyPrintRef (TypeRef _ pn (Just dctors)) = 1723 Just $ runProperName pn <> "(" <> T.intercalate ", " (map runProperName dctors) <> ")" 1724prettyPrintRef (TypeOpRef _ op) = 1725 Just $ "type " <> showOp op 1726prettyPrintRef (ValueRef _ ident) = 1727 Just $ showIdent ident 1728prettyPrintRef (ValueOpRef _ op) = 1729 Just $ showOp op 1730prettyPrintRef (TypeClassRef _ pn) = 1731 Just $ "class " <> runProperName pn 1732prettyPrintRef (TypeInstanceRef _ ident UserNamed) = 1733 Just $ showIdent ident 1734prettyPrintRef (TypeInstanceRef _ _ CompilerNamed) = 1735 Nothing 1736prettyPrintRef (ModuleRef _ name) = 1737 Just $ "module " <> runModuleName name 1738prettyPrintRef ReExportRef{} = 1739 Nothing 1740 1741prettyPrintKindSignatureFor :: KindSignatureFor -> Text 1742prettyPrintKindSignatureFor DataSig = "data" 1743prettyPrintKindSignatureFor NewtypeSig = "newtype" 1744prettyPrintKindSignatureFor TypeSynonymSig = "type" 1745prettyPrintKindSignatureFor ClassSig = "class" 1746 1747prettyPrintSuggestedTypeSimplified :: Type a -> String 1748prettyPrintSuggestedTypeSimplified = prettyPrintSuggestedType . eraseForAllKindAnnotations . eraseKindApps 1749 1750-- | Pretty print multiple errors 1751prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String 1752prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions 1753 1754-- | Pretty print multiple warnings 1755prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String 1756prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions 1757 1758-- | Pretty print warnings as a Box 1759prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box.Box] 1760prettyPrintMultipleWarningsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Warning }) "Warning found:" "Warning" 1761 1762-- | Pretty print errors as a Box 1763prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box.Box] 1764prettyPrintMultipleErrorsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Error }) "Error found:" "Error" 1765 1766prettyPrintMultipleErrorsWith :: PPEOptions -> String -> String -> MultipleErrors -> [Box.Box] 1767prettyPrintMultipleErrorsWith ppeOptions intro _ (MultipleErrors [e]) = 1768 let result = prettyPrintSingleError ppeOptions e 1769 in [ Box.vcat Box.left [ Box.text intro 1770 , result 1771 ] 1772 ] 1773prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) = 1774 let result = map (prettyPrintSingleError ppeOptions) es 1775 in concat $ zipWith withIntro [1 :: Int ..] result 1776 where 1777 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":") 1778 , Box.moveRight 2 err 1779 ] 1780 1781-- | Pretty print a Parsec ParseError as a Box 1782prettyPrintParseError :: P.ParseError -> Box.Box 1783prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages 1784 1785-- | Pretty print 'ParseError' detail messages. 1786-- 1787-- Adapted from 'Text.Parsec.Error.showErrorMessages'. 1788-- See <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>. 1789prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box 1790prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs 1791 | null msgs = Box.text msgUnknown 1792 | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages] 1793 1794 where 1795 (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs 1796 (unExpect,msgs2) = span (UnExpect "" ==) msgs1 1797 (expect,messages) = span (Expect "" ==) msgs2 1798 1799 showExpect = showMany msgExpecting expect 1800 showUnExpect = showMany msgUnExpected unExpect 1801 showSysUnExpect | not (null unExpect) || 1802 null sysUnExpect = "" 1803 | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput 1804 | otherwise = msgUnExpected ++ " " ++ firstMsg 1805 where 1806 firstMsg = PE.messageString (head sysUnExpect) 1807 1808 showMessages = showMany "" messages 1809 1810 -- helpers 1811 showMany pre msgs' = case clean (map PE.messageString msgs') of 1812 [] -> "" 1813 ms | null pre -> commasOr ms 1814 | otherwise -> pre ++ " " ++ commasOr ms 1815 1816 commasOr [] = "" 1817 commasOr [m] = m 1818 commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms 1819 1820 commaSep = separate ", " . clean 1821 1822 separate _ [] = "" 1823 separate _ [m] = m 1824 separate sep (m:ms) = m ++ sep ++ separate sep ms 1825 1826 clean = ordNub . filter (not . null) 1827 1828-- | Indent to the right, and pad on top and bottom. 1829indent :: Box.Box -> Box.Box 1830indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2 1831 1832line :: Text -> Box.Box 1833line = Box.text . T.unpack 1834 1835lineS :: String -> Box.Box 1836lineS = Box.text 1837 1838renderBox :: Box.Box -> String 1839renderBox = unlines 1840 . map (dropWhileEnd isSpace) 1841 . dropWhile whiteSpace 1842 . dropWhileEnd whiteSpace 1843 . lines 1844 . Box.render 1845 where 1846 whiteSpace = all isSpace 1847 1848toTypelevelString :: Type a -> Maybe Box.Box 1849toTypelevelString (TypeLevelString _ s) = 1850 Just . Box.text $ decodeStringWithReplacement s 1851toTypelevelString (TypeApp _ (TypeConstructor _ f) x) 1852 | f == primSubName C.typeError "Text" = toTypelevelString x 1853toTypelevelString (TypeApp _ (TypeConstructor _ f) x) 1854 | f == primSubName C.typeError "Quote" = Just (typeAsBox maxBound x) 1855toTypelevelString (TypeApp _ (TypeConstructor _ f) (TypeLevelString _ x)) 1856 | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x 1857toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) 1858 | f == primSubName C.typeError "Beside" = 1859 (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret 1860toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) 1861 | f == primSubName C.typeError "Above" = 1862 (Box.//) <$> toTypelevelString x <*> toTypelevelString ret 1863toTypelevelString _ = Nothing 1864 1865-- | Rethrow an error with a more detailed error message in the case of failure 1866rethrow :: (MonadError e m) => (e -> e) -> m a -> m a 1867rethrow f = flip catchError (throwError . f) 1868 1869warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a 1870warnAndRethrow f = rethrow f . censor f 1871 1872-- | Rethrow an error with source position information 1873rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a 1874rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos)) 1875 1876warnWithPosition :: (MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a 1877warnWithPosition pos = censor (onErrorMessages (withPosition pos)) 1878 1879warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a 1880warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos 1881 1882withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage 1883withPosition NullSourceSpan err = err 1884withPosition pos (ErrorMessage hints se) = ErrorMessage (positionedError pos : hints) se 1885 1886withoutPosition :: ErrorMessage -> ErrorMessage 1887withoutPosition (ErrorMessage hints se) = ErrorMessage (filter go hints) se 1888 where 1889 go (PositionedError _) = False 1890 go _ = True 1891 1892positionedError :: SourceSpan -> ErrorMessageHint 1893positionedError = PositionedError . pure 1894 1895filterErrors :: (ErrorMessage -> Bool) -> MultipleErrors -> MultipleErrors 1896filterErrors f = MultipleErrors . filter f . runMultipleErrors 1897 1898-- | Runs a computation listening for warnings and then escalating any warnings 1899-- that match the predicate to error status. 1900escalateWarningWhen 1901 :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m) 1902 => (ErrorMessage -> Bool) 1903 -> m a 1904 -> m a 1905escalateWarningWhen isError ma = do 1906 (a, w) <- censor (const mempty) $ listen ma 1907 let (errors, warnings) = partition isError (runMultipleErrors w) 1908 tell $ MultipleErrors warnings 1909 unless (null errors) $ throwError $ MultipleErrors errors 1910 return a 1911 1912-- | Collect errors in in parallel 1913parU 1914 :: forall m a b 1915 . MonadError MultipleErrors m 1916 => [a] 1917 -> (a -> m b) 1918 -> m [b] 1919parU xs f = 1920 forM xs (withError . f) >>= collectErrors 1921 where 1922 withError :: m b -> m (Either MultipleErrors b) 1923 withError u = catchError (Right <$> u) (return . Left) 1924 1925 collectErrors :: [Either MultipleErrors b] -> m [b] 1926 collectErrors es = case partitionEithers es of 1927 ([], rs) -> return rs 1928 (errs, _) -> throwError $ fold errs 1929 1930internalCompilerError 1931 :: (MonadError MultipleErrors m, GHC.Stack.HasCallStack) 1932 => Text 1933 -> m a 1934internalCompilerError = 1935 throwError 1936 . errorMessage 1937 . InternalCompilerError (T.pack (GHC.Stack.prettyCallStack GHC.Stack.callStack)) 1938