module Language.PureScript.Errors
  ( module Language.PureScript.AST
  , module Language.PureScript.Errors
  ) where

import Prelude
import Protolude (unsnoc)

import Control.Arrow ((&&&))
import Control.Exception (displayException)
import Control.Lens (both, head1, over)
import Control.Monad (forM, unless)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.State.Lazy (State, evalState, get, put)
import Control.Monad.Writer (Last(..), MonadWriter(..), censor)
import Data.Bifunctor (first, second)
import Data.Bitraversable (bitraverse)
import Data.Char (isSpace)
import Data.Containers.ListUtils (nubOrdOn)
import Data.Either (partitionEithers)
import Data.Foldable (fold)
import Data.Function (on)
import Data.Functor (($>))
import Data.Functor.Identity (Identity(..))
import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn, uncons)
import Data.List.NonEmpty qualified as NEL
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Maybe (maybeToList, fromMaybe, isJust, mapMaybe)
import Data.Map qualified as M
import Data.Ord (Down(..))
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text (Text)
import Data.Traversable (for)
import GHC.Stack qualified
import Language.PureScript.AST
import Language.PureScript.Bundle qualified as Bundle
import Language.PureScript.Constants.Libs qualified as C
import Language.PureScript.Constants.Prim qualified as C
import Language.PureScript.Crash (internalError)
import Language.PureScript.CST.Errors qualified as CST
import Language.PureScript.CST.Print qualified as CST
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names
import Language.PureScript.Pretty (prettyPrintBinderAtom, prettyPrintLabel, prettyPrintObjectKey, prettyPrintSuggestedType, prettyPrintValue, typeAsBox, typeAtomAsBox, typeDiffAsBox)
import Language.PureScript.Pretty.Common (endWith)
import Language.PureScript.PSString (decodeStringWithReplacement)
import Language.PureScript.Roles (Role, displayRole)
import Language.PureScript.Traversals (sndM)
import Language.PureScript.Types (Constraint(..), ConstraintData(..), RowListItem(..), SourceConstraint, SourceType, Type(..), eraseForAllKindAnnotations, eraseKindApps, everywhereOnTypesTopDownM, getAnnForType, isMonoType, overConstraintArgs, rowFromList, rowToList, srcTUnknown)
import Language.PureScript.Publish.BoxesHelpers qualified as BoxHelpers
import System.Console.ANSI qualified as ANSI
import System.FilePath (makeRelative)
import Text.PrettyPrint.Boxes qualified as Box
import Witherable (wither)

-- | A type of error messages
data SimpleErrorMessage
  = InternalCompilerError Text Text
  | ModuleNotFound ModuleName
  | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
  | ErrorParsingCSTModule CST.ParserError
  | WarningParsingCSTModule CST.ParserWarning
  | MissingFFIModule ModuleName
  | UnnecessaryFFIModule ModuleName FilePath
  | MissingFFIImplementations ModuleName [Ident]
  | UnusedFFIImplementations ModuleName [Ident]
  | InvalidFFIIdentifier ModuleName Text
  | DeprecatedFFIPrime ModuleName Text
  | DeprecatedFFICommonJSModule ModuleName FilePath
  | UnsupportedFFICommonJSExports ModuleName [Text]
  | UnsupportedFFICommonJSImports ModuleName [Text]
  | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred
  | InfiniteType SourceType
  | InfiniteKind SourceType
  | MultipleValueOpFixities (OpName 'ValueOpName)
  | MultipleTypeOpFixities (OpName 'TypeOpName)
  | OrphanTypeDeclaration Ident
  | OrphanKindDeclaration (ProperName 'TypeName)
  | OrphanRoleDeclaration (ProperName 'TypeName)
  | RedefinedIdent Ident
  | OverlappingNamesInLet Ident
  | UnknownName (Qualified Name)
  | UnknownImport ModuleName Name
  | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
  | UnknownExport Name
  | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
  | ScopeConflict Name [ModuleName]
  | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
  | DeclConflict Name Name
  | ExportConflict (Qualified Name) (Qualified Name)
  | DuplicateModule ModuleName
  | DuplicateTypeClass (ProperName 'ClassName) SourceSpan
  | DuplicateInstance Ident SourceSpan
  | DuplicateTypeArgument Text
  | InvalidDoBind
  | InvalidDoLet
  | CycleInDeclaration Ident
  | CycleInTypeSynonym (NEL.NonEmpty (ProperName 'TypeName))
  | CycleInTypeClassDeclaration (NEL.NonEmpty (Qualified (ProperName 'ClassName)))
  | CycleInKindDeclaration (NEL.NonEmpty (Qualified (ProperName 'TypeName)))
  | CycleInModules (NEL.NonEmpty ModuleName)
  | NameIsUndefined Ident
  | UndefinedTypeVariable (ProperName 'TypeName)
  | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
  | EscapedSkolem Text (Maybe SourceSpan) SourceType
  | TypesDoNotUnify SourceType SourceType
  | KindsDoNotUnify SourceType SourceType
  | ConstrainedTypeUnified SourceType SourceType
  | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified (Either SourceType Ident)]
  | NoInstanceFound
      SourceConstraint -- ^ constraint that could not be solved
      [Qualified (Either SourceType Ident)] -- ^ a list of instances that stopped further progress in instance chains due to ambiguity
      UnknownsHint -- ^ whether eliminating unknowns with annotations might help or if visible type applications are required
  | AmbiguousTypeVariables SourceType [(Text, Int)]
  | UnknownClass (Qualified (ProperName 'ClassName))
  | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType]
  | PossiblyInfiniteCoercibleInstance
  | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType]
  | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int
  | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType
  | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [SourceType]
  | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType]
  | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType]
  | CannotFindDerivingType (ProperName 'TypeName)
  | DuplicateLabel Label (Maybe Expr)
  | DuplicateValueDeclaration Ident
  | ArgListLengthsDiffer Ident
  | OverlappingArgNames (Maybe Ident)
  | MissingClassMember (NEL.NonEmpty (Ident, SourceType))
  | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))
  | ExpectedType SourceType SourceType
  -- | constructor name, expected argument count, actual argument count
  | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int
  | ExprDoesNotHaveType Expr SourceType
  | PropertyIsMissing Label
  | AdditionalProperty Label
  | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (S.Set ModuleName) [SourceType]
  | InvalidNewtype (ProperName 'TypeName)
  | InvalidInstanceHead SourceType
  | TransitiveExportError DeclarationRef [DeclarationRef]
  | TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName]
  | HiddenConstructors DeclarationRef (Qualified (ProperName 'ClassName))
  | ShadowedName Ident
  | ShadowedTypeVar Text
  | UnusedTypeVar Text
  | UnusedName Ident
  | UnusedDeclaration Ident
  | WildcardInferredType SourceType Context
  | HoleInferredType Text SourceType Context (Maybe TypeSearch)
  | MissingTypeDeclaration Ident SourceType
  | MissingKindDeclaration KindSignatureFor (ProperName 'TypeName) SourceType
  | OverlappingPattern [[Binder]] Bool
  | IncompleteExhaustivityCheck
  | ImportHidingModule ModuleName
  | UnusedImport ModuleName (Maybe ModuleName)
  | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef]
  | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef]
  | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef]
  | DuplicateSelectiveImport ModuleName
  | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
  | DuplicateImportRef Name
  | DuplicateExportRef Name
  | IntOutOfRange Integer Text Integer Integer
  | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]
  | ImplicitQualifiedImportReExport ModuleName ModuleName [DeclarationRef]
  | ImplicitImport ModuleName [DeclarationRef]
  | HidingImport ModuleName [DeclarationRef]
  | CaseBinderLengthDiffers Int [Binder]
  | IncorrectAnonymousArgument
  | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
  | CannotGeneralizeRecursiveFunction Ident SourceType
  | CannotDeriveNewtypeForData (ProperName 'TypeName)
  | ExpectedWildcard (ProperName 'TypeName)
  | CannotUseBindWithDo Ident
  -- | instance name, type class, expected argument count, actual argument count
  | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int
  -- | a user-defined warning raised by using the Warn type class
  | UserDefinedWarning SourceType
  | CannotDefinePrimModules ModuleName
  | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity))
  | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName)))
  | QuantificationCheckFailureInKind Text
  | QuantificationCheckFailureInType [Int] SourceType
  | VisibleQuantificationCheckFailureInType Text
  | UnsupportedTypeInKind SourceType
  -- | Declared role was more permissive than inferred.
  | RoleMismatch
      Text -- ^ Type variable in question
      Role -- ^ inferred role
      Role -- ^ declared role
  | InvalidCoercibleInstanceDeclaration [SourceType]
  | UnsupportedRoleDeclaration
  | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int
  | DuplicateRoleDeclaration (ProperName 'TypeName)
  | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool
  | CannotSkipTypeApplication SourceType
  | CannotApplyExpressionOfTypeOnType SourceType SourceType
  deriving (Int -> SimpleErrorMessage -> ShowS
[SimpleErrorMessage] -> ShowS
SimpleErrorMessage -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SimpleErrorMessage] -> ShowS
$cshowList :: [SimpleErrorMessage] -> ShowS
show :: SimpleErrorMessage -> FilePath
$cshow :: SimpleErrorMessage -> FilePath
showsPrec :: Int -> SimpleErrorMessage -> ShowS
$cshowsPrec :: Int -> SimpleErrorMessage -> ShowS
Show)

data ErrorMessage = ErrorMessage
  [ErrorMessageHint]
  SimpleErrorMessage
  deriving (Int -> ErrorMessage -> ShowS
[ErrorMessage] -> ShowS
ErrorMessage -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ErrorMessage] -> ShowS
$cshowList :: [ErrorMessage] -> ShowS
show :: ErrorMessage -> FilePath
$cshow :: ErrorMessage -> FilePath
showsPrec :: Int -> ErrorMessage -> ShowS
$cshowsPrec :: Int -> ErrorMessage -> ShowS
Show)

newtype ErrorSuggestion = ErrorSuggestion Text

-- | Get the source span for an error
errorSpan :: ErrorMessage -> Maybe (NEL.NonEmpty SourceSpan)
errorSpan :: ErrorMessage -> Maybe (NonEmpty SourceSpan)
errorSpan = forall a. (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a
findHint ErrorMessageHint -> Maybe (NonEmpty SourceSpan)
matchPE forall a. Semigroup a => a -> a -> a
<> forall a. (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a
findHint ErrorMessageHint -> Maybe (NonEmpty SourceSpan)
matchRP
  where
  matchPE :: ErrorMessageHint -> Maybe (NonEmpty SourceSpan)
matchPE (PositionedError NonEmpty SourceSpan
sss) = forall a. a -> Maybe a
Just NonEmpty SourceSpan
sss
  matchPE ErrorMessageHint
_ = forall a. Maybe a
Nothing
  matchRP :: ErrorMessageHint -> Maybe (NonEmpty SourceSpan)
matchRP (RelatedPositions NonEmpty SourceSpan
sss) = forall a. a -> Maybe a
Just NonEmpty SourceSpan
sss
  matchRP ErrorMessageHint
_ = forall a. Maybe a
Nothing

-- | Get the module name for an error
errorModule :: ErrorMessage -> Maybe ModuleName
errorModule :: ErrorMessage -> Maybe ModuleName
errorModule = forall a. (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a
findHint ErrorMessageHint -> Maybe ModuleName
matchModule
  where
  matchModule :: ErrorMessageHint -> Maybe ModuleName
matchModule (ErrorInModule ModuleName
mn) = forall a. a -> Maybe a
Just ModuleName
mn
  matchModule ErrorMessageHint
_ = forall a. Maybe a
Nothing

findHint :: (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a
findHint :: forall a. (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a
findHint ErrorMessageHint -> Maybe a
f (ErrorMessage [ErrorMessageHint]
hints SimpleErrorMessage
_) = forall a. Last a -> Maybe a
getLast forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> Last a
Last forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> Maybe a
f) forall a b. (a -> b) -> a -> b
$ [ErrorMessageHint]
hints

-- | Remove the module name and span hints from an error
stripModuleAndSpan :: ErrorMessage -> ErrorMessage
stripModuleAndSpan :: ErrorMessage -> ErrorMessage
stripModuleAndSpan (ErrorMessage [ErrorMessageHint]
hints SimpleErrorMessage
e) = [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> Bool
shouldStrip) [ErrorMessageHint]
hints) SimpleErrorMessage
e
  where
  shouldStrip :: ErrorMessageHint -> Bool
shouldStrip (ErrorInModule ModuleName
_) = Bool
True
  shouldStrip (PositionedError NonEmpty SourceSpan
_) = Bool
True
  shouldStrip ErrorMessageHint
_ = Bool
False

-- | Get the error code for a particular error type
errorCode :: ErrorMessage -> Text
errorCode :: ErrorMessage -> Text
errorCode ErrorMessage
em = case ErrorMessage -> SimpleErrorMessage
unwrapErrorMessage ErrorMessage
em of
  InternalCompilerError{} -> Text
"InternalCompilerError"
  ModuleNotFound{} -> Text
"ModuleNotFound"
  ErrorParsingFFIModule{} -> Text
"ErrorParsingFFIModule"
  ErrorParsingCSTModule{} -> Text
"ErrorParsingModule"
  WarningParsingCSTModule{} -> Text
"WarningParsingModule"
  MissingFFIModule{} -> Text
"MissingFFIModule"
  UnnecessaryFFIModule{} -> Text
"UnnecessaryFFIModule"
  MissingFFIImplementations{} -> Text
"MissingFFIImplementations"
  UnusedFFIImplementations{} -> Text
"UnusedFFIImplementations"
  InvalidFFIIdentifier{} -> Text
"InvalidFFIIdentifier"
  DeprecatedFFIPrime{} -> Text
"DeprecatedFFIPrime"
  DeprecatedFFICommonJSModule {} -> Text
"DeprecatedFFICommonJSModule"
  UnsupportedFFICommonJSExports {} -> Text
"UnsupportedFFICommonJSExports"
  UnsupportedFFICommonJSImports {} -> Text
"UnsupportedFFICommonJSImports"
  FileIOError{} -> Text
"FileIOError"
  InfiniteType{} -> Text
"InfiniteType"
  InfiniteKind{} -> Text
"InfiniteKind"
  MultipleValueOpFixities{} -> Text
"MultipleValueOpFixities"
  MultipleTypeOpFixities{} -> Text
"MultipleTypeOpFixities"
  OrphanTypeDeclaration{} -> Text
"OrphanTypeDeclaration"
  OrphanKindDeclaration{} -> Text
"OrphanKindDeclaration"
  OrphanRoleDeclaration{} -> Text
"OrphanRoleDeclaration"
  RedefinedIdent{} -> Text
"RedefinedIdent"
  OverlappingNamesInLet{} -> Text
"OverlappingNamesInLet"
  UnknownName{} -> Text
"UnknownName"
  UnknownImport{} -> Text
"UnknownImport"
  UnknownImportDataConstructor{} -> Text
"UnknownImportDataConstructor"
  UnknownExport{} -> Text
"UnknownExport"
  UnknownExportDataConstructor{} -> Text
"UnknownExportDataConstructor"
  ScopeConflict{} -> Text
"ScopeConflict"
  ScopeShadowing{} -> Text
"ScopeShadowing"
  DeclConflict{} -> Text
"DeclConflict"
  ExportConflict{} -> Text
"ExportConflict"
  DuplicateModule{} -> Text
"DuplicateModule"
  DuplicateTypeClass{} -> Text
"DuplicateTypeClass"
  DuplicateInstance{} -> Text
"DuplicateInstance"
  DuplicateTypeArgument{} -> Text
"DuplicateTypeArgument"
  SimpleErrorMessage
InvalidDoBind -> Text
"InvalidDoBind"
  SimpleErrorMessage
InvalidDoLet -> Text
"InvalidDoLet"
  CycleInDeclaration{} -> Text
"CycleInDeclaration"
  CycleInTypeSynonym{} -> Text
"CycleInTypeSynonym"
  CycleInTypeClassDeclaration{} -> Text
"CycleInTypeClassDeclaration"
  CycleInKindDeclaration{} -> Text
"CycleInKindDeclaration"
  CycleInModules{} -> Text
"CycleInModules"
  NameIsUndefined{} -> Text
"NameIsUndefined"
  UndefinedTypeVariable{} -> Text
"UndefinedTypeVariable"
  PartiallyAppliedSynonym{} -> Text
"PartiallyAppliedSynonym"
  EscapedSkolem{} -> Text
"EscapedSkolem"
  TypesDoNotUnify{} -> Text
"TypesDoNotUnify"
  KindsDoNotUnify{} -> Text
"KindsDoNotUnify"
  ConstrainedTypeUnified{} -> Text
"ConstrainedTypeUnified"
  OverlappingInstances{} -> Text
"OverlappingInstances"
  NoInstanceFound{} -> Text
"NoInstanceFound"
  AmbiguousTypeVariables{} -> Text
"AmbiguousTypeVariables"
  UnknownClass{} -> Text
"UnknownClass"
  PossiblyInfiniteInstance{} -> Text
"PossiblyInfiniteInstance"
  SimpleErrorMessage
PossiblyInfiniteCoercibleInstance -> Text
"PossiblyInfiniteCoercibleInstance"
  CannotDerive{} -> Text
"CannotDerive"
  InvalidNewtypeInstance{} -> Text
"InvalidNewtypeInstance"
  MissingNewtypeSuperclassInstance{} -> Text
"MissingNewtypeSuperclassInstance"
  UnverifiableSuperclassInstance{} -> Text
"UnverifiableSuperclassInstance"
  InvalidDerivedInstance{} -> Text
"InvalidDerivedInstance"
  ExpectedTypeConstructor{} -> Text
"ExpectedTypeConstructor"
  CannotFindDerivingType{} -> Text
"CannotFindDerivingType"
  DuplicateLabel{} -> Text
"DuplicateLabel"
  DuplicateValueDeclaration{} -> Text
"DuplicateValueDeclaration"
  ArgListLengthsDiffer{} -> Text
"ArgListLengthsDiffer"
  OverlappingArgNames{} -> Text
"OverlappingArgNames"
  MissingClassMember{} -> Text
"MissingClassMember"
  ExtraneousClassMember{} -> Text
"ExtraneousClassMember"
  ExpectedType{} -> Text
"ExpectedType"
  IncorrectConstructorArity{} -> Text
"IncorrectConstructorArity"
  ExprDoesNotHaveType{} -> Text
"ExprDoesNotHaveType"
  PropertyIsMissing{} -> Text
"PropertyIsMissing"
  AdditionalProperty{} -> Text
"AdditionalProperty"
  OrphanInstance{} -> Text
"OrphanInstance"
  InvalidNewtype{} -> Text
"InvalidNewtype"
  InvalidInstanceHead{} -> Text
"InvalidInstanceHead"
  TransitiveExportError{} -> Text
"TransitiveExportError"
  TransitiveDctorExportError{} -> Text
"TransitiveDctorExportError"
  HiddenConstructors{} -> Text
"HiddenConstructors"
  ShadowedName{} -> Text
"ShadowedName"
  UnusedName{} -> Text
"UnusedName"
  UnusedDeclaration{} -> Text
"UnusedDeclaration"
  ShadowedTypeVar{} -> Text
"ShadowedTypeVar"
  UnusedTypeVar{} -> Text
"UnusedTypeVar"
  WildcardInferredType{} -> Text
"WildcardInferredType"
  HoleInferredType{} -> Text
"HoleInferredType"
  MissingTypeDeclaration{} -> Text
"MissingTypeDeclaration"
  MissingKindDeclaration{} -> Text
"MissingKindDeclaration"
  OverlappingPattern{} -> Text
"OverlappingPattern"
  IncompleteExhaustivityCheck{} -> Text
"IncompleteExhaustivityCheck"
  ImportHidingModule{} -> Text
"ImportHidingModule"
  UnusedImport{} -> Text
"UnusedImport"
  UnusedExplicitImport{} -> Text
"UnusedExplicitImport"
  UnusedDctorImport{} -> Text
"UnusedDctorImport"
  UnusedDctorExplicitImport{} -> Text
"UnusedDctorExplicitImport"
  DuplicateSelectiveImport{} -> Text
"DuplicateSelectiveImport"
  DuplicateImport{} -> Text
"DuplicateImport"
  DuplicateImportRef{} -> Text
"DuplicateImportRef"
  DuplicateExportRef{} -> Text
"DuplicateExportRef"
  IntOutOfRange{} -> Text
"IntOutOfRange"
  ImplicitQualifiedImport{} -> Text
"ImplicitQualifiedImport"
  ImplicitQualifiedImportReExport{} -> Text
"ImplicitQualifiedImportReExport"
  ImplicitImport{} -> Text
"ImplicitImport"
  HidingImport{} -> Text
"HidingImport"
  CaseBinderLengthDiffers{} -> Text
"CaseBinderLengthDiffers"
  SimpleErrorMessage
IncorrectAnonymousArgument -> Text
"IncorrectAnonymousArgument"
  InvalidOperatorInBinder{} -> Text
"InvalidOperatorInBinder"
  CannotGeneralizeRecursiveFunction{} -> Text
"CannotGeneralizeRecursiveFunction"
  CannotDeriveNewtypeForData{} -> Text
"CannotDeriveNewtypeForData"
  ExpectedWildcard{} -> Text
"ExpectedWildcard"
  CannotUseBindWithDo{} -> Text
"CannotUseBindWithDo"
  ClassInstanceArityMismatch{} -> Text
"ClassInstanceArityMismatch"
  UserDefinedWarning{} -> Text
"UserDefinedWarning"
  CannotDefinePrimModules{} -> Text
"CannotDefinePrimModules"
  MixedAssociativityError{} -> Text
"MixedAssociativityError"
  NonAssociativeError{} -> Text
"NonAssociativeError"
  QuantificationCheckFailureInKind {} -> Text
"QuantificationCheckFailureInKind"
  QuantificationCheckFailureInType {} -> Text
"QuantificationCheckFailureInType"
  VisibleQuantificationCheckFailureInType {} -> Text
"VisibleQuantificationCheckFailureInType"
  UnsupportedTypeInKind {} -> Text
"UnsupportedTypeInKind"
  RoleMismatch {} -> Text
"RoleMismatch"
  InvalidCoercibleInstanceDeclaration {} -> Text
"InvalidCoercibleInstanceDeclaration"
  UnsupportedRoleDeclaration {} -> Text
"UnsupportedRoleDeclaration"
  RoleDeclarationArityMismatch {} -> Text
"RoleDeclarationArityMismatch"
  DuplicateRoleDeclaration {} -> Text
"DuplicateRoleDeclaration"
  CannotDeriveInvalidConstructorArg{} -> Text
"CannotDeriveInvalidConstructorArg"
  CannotSkipTypeApplication{} -> Text
"CannotSkipTypeApplication"
  CannotApplyExpressionOfTypeOnType{} -> Text
"CannotApplyExpressionOfTypeOnType"

-- | A stack trace for an error
newtype MultipleErrors = MultipleErrors
  { MultipleErrors -> [ErrorMessage]
runMultipleErrors :: [ErrorMessage]
  } deriving (Int -> MultipleErrors -> ShowS
[MultipleErrors] -> ShowS
MultipleErrors -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MultipleErrors] -> ShowS
$cshowList :: [MultipleErrors] -> ShowS
show :: MultipleErrors -> FilePath
$cshow :: MultipleErrors -> FilePath
showsPrec :: Int -> MultipleErrors -> ShowS
$cshowsPrec :: Int -> MultipleErrors -> ShowS
Show, NonEmpty MultipleErrors -> MultipleErrors
MultipleErrors -> MultipleErrors -> MultipleErrors
forall b. Integral b => b -> MultipleErrors -> MultipleErrors
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> MultipleErrors -> MultipleErrors
$cstimes :: forall b. Integral b => b -> MultipleErrors -> MultipleErrors
sconcat :: NonEmpty MultipleErrors -> MultipleErrors
$csconcat :: NonEmpty MultipleErrors -> MultipleErrors
<> :: MultipleErrors -> MultipleErrors -> MultipleErrors
$c<> :: MultipleErrors -> MultipleErrors -> MultipleErrors
Semigroup, Semigroup MultipleErrors
MultipleErrors
[MultipleErrors] -> MultipleErrors
MultipleErrors -> MultipleErrors -> MultipleErrors
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [MultipleErrors] -> MultipleErrors
$cmconcat :: [MultipleErrors] -> MultipleErrors
mappend :: MultipleErrors -> MultipleErrors -> MultipleErrors
$cmappend :: MultipleErrors -> MultipleErrors -> MultipleErrors
mempty :: MultipleErrors
$cmempty :: MultipleErrors
Monoid)

-- | Check whether a collection of errors is empty or not.
nonEmpty :: MultipleErrors -> Bool
nonEmpty :: MultipleErrors -> Bool
nonEmpty = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipleErrors -> [ErrorMessage]
runMultipleErrors

-- | Create an error set from a single simple error message
errorMessage :: SimpleErrorMessage -> MultipleErrors
errorMessage :: SimpleErrorMessage -> MultipleErrors
errorMessage SimpleErrorMessage
err = [ErrorMessage] -> MultipleErrors
MultipleErrors [[ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage [] SimpleErrorMessage
err]

-- | Create an error set from a single simple error message and source annotation
errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss SimpleErrorMessage
err = [ErrorMessage] -> MultipleErrors
MultipleErrors [[ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage [SourceSpan -> ErrorMessageHint
positionedError SourceSpan
ss] SimpleErrorMessage
err]

-- | Create an error set from a single simple error message and source annotations
errorMessage'' :: NEL.NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage'' :: NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage'' NonEmpty SourceSpan
sss SimpleErrorMessage
err = [ErrorMessage] -> MultipleErrors
MultipleErrors [[ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage [NonEmpty SourceSpan -> ErrorMessageHint
PositionedError NonEmpty SourceSpan
sss] SimpleErrorMessage
err]

-- | Create an error from multiple (possibly empty) source spans, reversed sorted.
errorMessage''' :: [SourceSpan] -> SimpleErrorMessage -> MultipleErrors
errorMessage''' :: [SourceSpan] -> SimpleErrorMessage -> MultipleErrors
errorMessage''' [SourceSpan]
sss SimpleErrorMessage
err =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SimpleErrorMessage -> MultipleErrors
errorMessage SimpleErrorMessage
err) (forall a b c. (a -> b -> c) -> b -> a -> c
flip NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage'' SimpleErrorMessage
err)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. a -> Down a
Down
    forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= SourceSpan
NullSourceSpan) [SourceSpan]
sss

-- | Create an error set from a single error message
singleError :: ErrorMessage -> MultipleErrors
singleError :: ErrorMessage -> MultipleErrors
singleError = [ErrorMessage] -> MultipleErrors
MultipleErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Lift a function on ErrorMessage to a function on MultipleErrors
onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
onErrorMessages ErrorMessage -> ErrorMessage
f = [ErrorMessage] -> MultipleErrors
MultipleErrors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ErrorMessage -> ErrorMessage
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipleErrors -> [ErrorMessage]
runMultipleErrors

-- | Add a hint to an error message
addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint ErrorMessageHint
hint = [ErrorMessageHint] -> MultipleErrors -> MultipleErrors
addHints [ErrorMessageHint
hint]

-- | Add hints to an error message
addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors
addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors
addHints [ErrorMessageHint]
hints = (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
onErrorMessages forall a b. (a -> b) -> a -> b
$ \(ErrorMessage [ErrorMessageHint]
hints' SimpleErrorMessage
se) -> [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage ([ErrorMessageHint]
hints forall a. [a] -> [a] -> [a]
++ [ErrorMessageHint]
hints') SimpleErrorMessage
se

-- | A map from rigid type variable name/unknown variable pairs to new variables.
data TypeMap = TypeMap
  { TypeMap -> Map Int (FilePath, Int, Maybe SourceSpan)
umSkolemMap   :: M.Map Int (String, Int, Maybe SourceSpan)
  -- ^ a map from skolems to their new names, including source and naming info
  , TypeMap -> Map Int Int
umUnknownMap  :: M.Map Int Int
  -- ^ a map from unification variables to their new names
  , TypeMap -> Int
umNextIndex   :: Int
  -- ^ unknowns and skolems share a source of names during renaming, to
  -- avoid overlaps in error messages. This is the next label for either case.
  } deriving Int -> TypeMap -> ShowS
[TypeMap] -> ShowS
TypeMap -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TypeMap] -> ShowS
$cshowList :: [TypeMap] -> ShowS
show :: TypeMap -> FilePath
$cshow :: TypeMap -> FilePath
showsPrec :: Int -> TypeMap -> ShowS
$cshowsPrec :: Int -> TypeMap -> ShowS
Show

defaultUnknownMap :: TypeMap
defaultUnknownMap :: TypeMap
defaultUnknownMap = Map Int (FilePath, Int, Maybe SourceSpan)
-> Map Int Int -> Int -> TypeMap
TypeMap forall k a. Map k a
M.empty forall k a. Map k a
M.empty Int
0

-- | How critical the issue is
data Level = Error | Warning deriving Int -> Level -> ShowS
[Level] -> ShowS
Level -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Level] -> ShowS
$cshowList :: [Level] -> ShowS
show :: Level -> FilePath
$cshow :: Level -> FilePath
showsPrec :: Int -> Level -> ShowS
$cshowsPrec :: Int -> Level -> ShowS
Show

-- | Extract nested error messages from wrapper errors
unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
unwrapErrorMessage (ErrorMessage [ErrorMessageHint]
_ SimpleErrorMessage
se) = SimpleErrorMessage
se

replaceUnknowns :: SourceType -> State TypeMap SourceType
replaceUnknowns :: Type SourceAnn -> State TypeMap (Type SourceAnn)
replaceUnknowns = forall (m :: * -> *) a.
Monad m =>
(Type a -> m (Type a)) -> Type a -> m (Type a)
everywhereOnTypesTopDownM Type SourceAnn -> State TypeMap (Type SourceAnn)
replaceTypes where
  replaceTypes :: SourceType -> State TypeMap SourceType
  replaceTypes :: Type SourceAnn -> State TypeMap (Type SourceAnn)
replaceTypes (TUnknown SourceAnn
ann Int
u) = do
    TypeMap
m <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
u (TypeMap -> Map Int Int
umUnknownMap TypeMap
m) of
      Maybe Int
Nothing -> do
        let u' :: Int
u' = TypeMap -> Int
umNextIndex TypeMap
m
        forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ TypeMap
m { umUnknownMap :: Map Int Int
umUnknownMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
u Int
u' (TypeMap -> Map Int Int
umUnknownMap TypeMap
m), umNextIndex :: Int
umNextIndex = Int
u' forall a. Num a => a -> a -> a
+ Int
1 }
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Int -> Type a
TUnknown SourceAnn
ann Int
u')
      Just Int
u' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Int -> Type a
TUnknown SourceAnn
ann Int
u')
  -- We intentionally remove the kinds from skolems, because they are never
  -- presented when pretty-printing. Any unknowns in those kinds shouldn't
  -- appear in the list of unknowns unless used somewhere else.
  replaceTypes (Skolem SourceAnn
ann Text
name Maybe (Type SourceAnn)
_ Int
s SkolemScope
sko) = do
    TypeMap
m <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
s (TypeMap -> Map Int (FilePath, Int, Maybe SourceSpan)
umSkolemMap TypeMap
m) of
      Maybe (FilePath, Int, Maybe SourceSpan)
Nothing -> do
        let s' :: Int
s' = TypeMap -> Int
umNextIndex TypeMap
m
        forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ TypeMap
m { umSkolemMap :: Map Int (FilePath, Int, Maybe SourceSpan)
umSkolemMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
s (Text -> FilePath
T.unpack Text
name, Int
s', forall a. a -> Maybe a
Just (forall a b. (a, b) -> a
fst SourceAnn
ann)) (TypeMap -> Map Int (FilePath, Int, Maybe SourceSpan)
umSkolemMap TypeMap
m), umNextIndex :: Int
umNextIndex = Int
s' forall a. Num a => a -> a -> a
+ Int
1 }
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
a -> Text -> Maybe (Type a) -> Int -> SkolemScope -> Type a
Skolem SourceAnn
ann Text
name forall a. Maybe a
Nothing Int
s' SkolemScope
sko)
      Just (FilePath
_, Int
s', Maybe SourceSpan
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
a -> Text -> Maybe (Type a) -> Int -> SkolemScope -> Type a
Skolem SourceAnn
ann Text
name forall a. Maybe a
Nothing Int
s' SkolemScope
sko)
  replaceTypes Type SourceAnn
other = forall (m :: * -> *) a. Monad m => a -> m a
return Type SourceAnn
other

onTypesInErrorMessage :: (SourceType -> SourceType) -> ErrorMessage -> ErrorMessage
onTypesInErrorMessage :: (Type SourceAnn -> Type SourceAnn) -> ErrorMessage -> ErrorMessage
onTypesInErrorMessage Type SourceAnn -> Type SourceAnn
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
Applicative m =>
(Type SourceAnn -> m (Type SourceAnn))
-> ErrorMessage -> m ErrorMessage
onTypesInErrorMessageM (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type SourceAnn -> Type SourceAnn
f)

onTypesInErrorMessageM :: Applicative m => (SourceType -> m SourceType) -> ErrorMessage -> m ErrorMessage
onTypesInErrorMessageM :: forall (m :: * -> *).
Applicative m =>
(Type SourceAnn -> m (Type SourceAnn))
-> ErrorMessage -> m ErrorMessage
onTypesInErrorMessageM Type SourceAnn -> m (Type SourceAnn)
f (ErrorMessage [ErrorMessageHint]
hints SimpleErrorMessage
simple) = [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ErrorMessageHint -> m ErrorMessageHint
gHint [ErrorMessageHint]
hints forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SimpleErrorMessage -> m SimpleErrorMessage
gSimple SimpleErrorMessage
simple
  where
  gSimple :: SimpleErrorMessage -> m SimpleErrorMessage
gSimple (InfiniteType Type SourceAnn
t) = Type SourceAnn -> SimpleErrorMessage
InfiniteType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t
  gSimple (TypesDoNotUnify Type SourceAnn
t1 Type SourceAnn
t2) = Type SourceAnn -> Type SourceAnn -> SimpleErrorMessage
TypesDoNotUnify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t2
  gSimple (ConstrainedTypeUnified Type SourceAnn
t1 Type SourceAnn
t2) = Type SourceAnn -> Type SourceAnn -> SimpleErrorMessage
ConstrainedTypeUnified forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t2
  gSimple (ExprDoesNotHaveType Expr
e Type SourceAnn
t) = Expr -> Type SourceAnn -> SimpleErrorMessage
ExprDoesNotHaveType Expr
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t
  gSimple (InvalidInstanceHead Type SourceAnn
t) = Type SourceAnn -> SimpleErrorMessage
InvalidInstanceHead forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t
  gSimple (NoInstanceFound SourceConstraint
con [Qualified (Either (Type SourceAnn) Ident)]
ambig UnknownsHint
unks) = SourceConstraint
-> [Qualified (Either (Type SourceAnn) Ident)]
-> UnknownsHint
-> SimpleErrorMessage
NoInstanceFound forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f) SourceConstraint
con forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Qualified (Either (Type SourceAnn) Ident)]
ambig forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure UnknownsHint
unks
  gSimple (AmbiguousTypeVariables Type SourceAnn
t [(Text, Int)]
uis) = Type SourceAnn -> [(Text, Int)] -> SimpleErrorMessage
AmbiguousTypeVariables forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Text, Int)]
uis
  gSimple (OverlappingInstances Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts [Qualified (Either (Type SourceAnn) Ident)]
insts) = Qualified (ProperName 'ClassName)
-> [Type SourceAnn]
-> [Qualified (Either (Type SourceAnn) Ident)]
-> SimpleErrorMessage
OverlappingInstances Qualified (ProperName 'ClassName)
cl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse Type SourceAnn -> m (Type SourceAnn)
f forall (f :: * -> *) a. Applicative f => a -> f a
pure) [Qualified (Either (Type SourceAnn) Ident)]
insts
  gSimple (PossiblyInfiniteInstance Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts) = Qualified (ProperName 'ClassName)
-> [Type SourceAnn] -> SimpleErrorMessage
PossiblyInfiniteInstance Qualified (ProperName 'ClassName)
cl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts
  gSimple (CannotDerive Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts) = Qualified (ProperName 'ClassName)
-> [Type SourceAnn] -> SimpleErrorMessage
CannotDerive Qualified (ProperName 'ClassName)
cl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts
  gSimple (InvalidNewtypeInstance Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts) = Qualified (ProperName 'ClassName)
-> [Type SourceAnn] -> SimpleErrorMessage
InvalidNewtypeInstance Qualified (ProperName 'ClassName)
cl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts
  gSimple (MissingNewtypeSuperclassInstance Qualified (ProperName 'ClassName)
cl1 Qualified (ProperName 'ClassName)
cl2 [Type SourceAnn]
ts) = Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName)
-> [Type SourceAnn]
-> SimpleErrorMessage
MissingNewtypeSuperclassInstance Qualified (ProperName 'ClassName)
cl1 Qualified (ProperName 'ClassName)
cl2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts
  gSimple (UnverifiableSuperclassInstance Qualified (ProperName 'ClassName)
cl1 Qualified (ProperName 'ClassName)
cl2 [Type SourceAnn]
ts) = Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName)
-> [Type SourceAnn]
-> SimpleErrorMessage
UnverifiableSuperclassInstance Qualified (ProperName 'ClassName)
cl1 Qualified (ProperName 'ClassName)
cl2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts
  gSimple (InvalidDerivedInstance Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts Int
n) = Qualified (ProperName 'ClassName)
-> [Type SourceAnn] -> Int -> SimpleErrorMessage
InvalidDerivedInstance Qualified (ProperName 'ClassName)
cl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
  gSimple (ExpectedTypeConstructor Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts Type SourceAnn
ty) = Qualified (ProperName 'ClassName)
-> [Type SourceAnn] -> Type SourceAnn -> SimpleErrorMessage
ExpectedTypeConstructor Qualified (ProperName 'ClassName)
cl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
ty
  gSimple (ExpectedType Type SourceAnn
ty Type SourceAnn
k) = Type SourceAnn -> Type SourceAnn -> SimpleErrorMessage
ExpectedType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type SourceAnn
k
  gSimple (OrphanInstance Ident
nm Qualified (ProperName 'ClassName)
cl Set ModuleName
noms [Type SourceAnn]
ts) = Ident
-> Qualified (ProperName 'ClassName)
-> Set ModuleName
-> [Type SourceAnn]
-> SimpleErrorMessage
OrphanInstance Ident
nm Qualified (ProperName 'ClassName)
cl Set ModuleName
noms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts
  gSimple (WildcardInferredType Type SourceAnn
ty Context
ctx) = Type SourceAnn -> Context -> SimpleErrorMessage
WildcardInferredType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM Type SourceAnn -> m (Type SourceAnn)
f) Context
ctx
  gSimple (HoleInferredType Text
name Type SourceAnn
ty Context
ctx Maybe TypeSearch
env) = Text
-> Type SourceAnn
-> Context
-> Maybe TypeSearch
-> SimpleErrorMessage
HoleInferredType Text
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM Type SourceAnn -> m (Type SourceAnn)
f) Context
ctx  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
Applicative m =>
(Type SourceAnn -> m (Type SourceAnn))
-> TypeSearch -> m TypeSearch
onTypeSearchTypesM Type SourceAnn -> m (Type SourceAnn)
f) Maybe TypeSearch
env
  gSimple (MissingTypeDeclaration Ident
nm Type SourceAnn
ty) = Ident -> Type SourceAnn -> SimpleErrorMessage
MissingTypeDeclaration Ident
nm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
ty
  gSimple (MissingKindDeclaration KindSignatureFor
sig ProperName 'TypeName
nm Type SourceAnn
ty) = KindSignatureFor
-> ProperName 'TypeName -> Type SourceAnn -> SimpleErrorMessage
MissingKindDeclaration KindSignatureFor
sig ProperName 'TypeName
nm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
ty
  gSimple (CannotGeneralizeRecursiveFunction Ident
nm Type SourceAnn
ty) = Ident -> Type SourceAnn -> SimpleErrorMessage
CannotGeneralizeRecursiveFunction Ident
nm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
ty
  gSimple (InvalidCoercibleInstanceDeclaration [Type SourceAnn]
tys) = [Type SourceAnn] -> SimpleErrorMessage
InvalidCoercibleInstanceDeclaration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
tys
  gSimple SimpleErrorMessage
other = forall (f :: * -> *) a. Applicative f => a -> f a
pure SimpleErrorMessage
other

  gHint :: ErrorMessageHint -> m ErrorMessageHint
gHint (ErrorInSubsumption Type SourceAnn
t1 Type SourceAnn
t2) = Type SourceAnn -> Type SourceAnn -> ErrorMessageHint
ErrorInSubsumption forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t2
  gHint (ErrorUnifyingTypes Type SourceAnn
t1 Type SourceAnn
t2) = Type SourceAnn -> Type SourceAnn -> ErrorMessageHint
ErrorUnifyingTypes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t2
  gHint (ErrorCheckingType Expr
e Type SourceAnn
t) = Expr -> Type SourceAnn -> ErrorMessageHint
ErrorCheckingType Expr
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t
  gHint (ErrorCheckingKind Type SourceAnn
t Type SourceAnn
k) = Type SourceAnn -> Type SourceAnn -> ErrorMessageHint
ErrorCheckingKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
k
  gHint (ErrorInferringKind Type SourceAnn
t) = Type SourceAnn -> ErrorMessageHint
ErrorInferringKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t
  gHint (ErrorInApplication Expr
e1 Type SourceAnn
t1 Expr
e2) = Expr -> Type SourceAnn -> Expr -> ErrorMessageHint
ErrorInApplication Expr
e1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type SourceAnn -> m (Type SourceAnn)
f Type SourceAnn
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
e2
  gHint (ErrorInInstance Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts) = Qualified (ProperName 'ClassName)
-> [Type SourceAnn] -> ErrorMessageHint
ErrorInInstance Qualified (ProperName 'ClassName)
cl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f [Type SourceAnn]
ts
  gHint (ErrorSolvingConstraint SourceConstraint
con) = SourceConstraint -> ErrorMessageHint
ErrorSolvingConstraint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
Functor f =>
([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a)
overConstraintArgs (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type SourceAnn -> m (Type SourceAnn)
f) SourceConstraint
con
  gHint ErrorMessageHint
other = forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorMessageHint
other

errorDocUri :: ErrorMessage -> Text
errorDocUri :: ErrorMessage -> Text
errorDocUri ErrorMessage
e = Text
"https://github.com/purescript/documentation/blob/master/errors/" forall a. Semigroup a => a -> a -> a
<> ErrorMessage -> Text
errorCode ErrorMessage
e forall a. Semigroup a => a -> a -> a
<> Text
".md"

-- TODO Other possible suggestions:
-- WildcardInferredType - source span not small enough
-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert
errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion
errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion
errorSuggestion SimpleErrorMessage
err =
    case SimpleErrorMessage
err of
      UnusedImport{} -> Maybe ErrorSuggestion
emptySuggestion
      DuplicateImport{} -> Maybe ErrorSuggestion
emptySuggestion
      UnusedExplicitImport ModuleName
mn [Name]
_ Maybe ModuleName
qual [DeclarationRef]
refs -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs Maybe ModuleName
qual
      UnusedDctorImport ModuleName
mn ProperName 'TypeName
_ Maybe ModuleName
qual [DeclarationRef]
refs -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs Maybe ModuleName
qual
      UnusedDctorExplicitImport ModuleName
mn ProperName 'TypeName
_ [ProperName 'ConstructorName]
_ Maybe ModuleName
qual [DeclarationRef]
refs -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs Maybe ModuleName
qual
      ImplicitImport ModuleName
mn [DeclarationRef]
refs -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs forall a. Maybe a
Nothing
      ImplicitQualifiedImport ModuleName
mn ModuleName
asModule [DeclarationRef]
refs -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs (forall a. a -> Maybe a
Just ModuleName
asModule)
      ImplicitQualifiedImportReExport ModuleName
mn ModuleName
asModule [DeclarationRef]
refs -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs (forall a. a -> Maybe a
Just ModuleName
asModule)
      HidingImport ModuleName
mn [DeclarationRef]
refs -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs forall a. Maybe a
Nothing
      MissingTypeDeclaration Ident
ident Type SourceAnn
ty -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ Ident -> Text
showIdent Ident
ident forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Type a -> FilePath
prettyPrintSuggestedTypeSimplified Type SourceAnn
ty) forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      MissingKindDeclaration KindSignatureFor
sig ProperName 'TypeName
name Type SourceAnn
ty -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ KindSignatureFor -> Text
prettyPrintKindSignatureFor KindSignatureFor
sig forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Type a -> FilePath
prettyPrintSuggestedTypeSimplified Type SourceAnn
ty) forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      WildcardInferredType Type SourceAnn
ty Context
_ -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (forall a. Type a -> FilePath
prettyPrintSuggestedTypeSimplified Type SourceAnn
ty)
      WarningParsingCSTModule ParserWarning
pe -> do
        let toks :: [SourceToken]
toks = forall a. ParserErrorInfo a -> [SourceToken]
CST.errToks ParserWarning
pe
        case forall a. ParserErrorInfo a -> a
CST.errType ParserWarning
pe of
          ParserWarningType
CST.WarnDeprecatedRowSyntax -> do
            let kind :: Text
kind = [SourceToken] -> Text
CST.printTokens forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [SourceToken]
toks
                sugg :: Text
sugg | Text
" " Text -> Text -> Bool
`T.isPrefixOf` Text
kind = Text
"Row" forall a. Semigroup a => a -> a -> a
<> Text
kind
                     | Bool
otherwise = Text
"Row " forall a. Semigroup a => a -> a -> a
<> Text
kind
            Text -> Maybe ErrorSuggestion
suggest Text
sugg
          ParserWarningType
CST.WarnDeprecatedForeignKindSyntax -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> [SourceToken] -> Text
CST.printTokens (forall a. Int -> [a] -> [a]
drop Int
3 [SourceToken]
toks)
          ParserWarningType
CST.WarnDeprecatedKindImportSyntax -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ [SourceToken] -> Text
CST.printTokens forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [SourceToken]
toks
          ParserWarningType
CST.WarnDeprecatedKindExportSyntax -> Text -> Maybe ErrorSuggestion
suggest forall a b. (a -> b) -> a -> b
$ [SourceToken] -> Text
CST.printTokens forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [SourceToken]
toks
          ParserWarningType
CST.WarnDeprecatedCaseOfOffsideSyntax -> forall a. Maybe a
Nothing
      SimpleErrorMessage
_ -> forall a. Maybe a
Nothing
  where
    emptySuggestion :: Maybe ErrorSuggestion
emptySuggestion = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ErrorSuggestion
ErrorSuggestion Text
""
    suggest :: Text -> Maybe ErrorSuggestion
suggest = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorSuggestion
ErrorSuggestion

    importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text
    importSuggestion :: ModuleName -> [DeclarationRef] -> Maybe ModuleName -> Text
importSuggestion ModuleName
mn [DeclarationRef]
refs Maybe ModuleName
qual =
      Text
"import " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
runModuleName ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DeclarationRef -> Maybe Text
prettyPrintRef [DeclarationRef]
refs) forall a. Semigroup a => a -> a -> a
<> Text
")" forall a. Semigroup a => a -> a -> a
<> Maybe ModuleName -> Text
qstr Maybe ModuleName
qual

    qstr :: Maybe ModuleName -> Text
    qstr :: Maybe ModuleName -> Text
qstr (Just ModuleName
mn) = Text
" as " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
runModuleName ModuleName
mn
    qstr Maybe ModuleName
Nothing = Text
""

suggestionSpan :: ErrorMessage -> Maybe SourceSpan
suggestionSpan :: ErrorMessage -> Maybe SourceSpan
suggestionSpan ErrorMessage
e =
  -- The `NEL.head` is a bit arbitrary here, but I don't think we'll
  -- have errors-with-suggestions that also have multiple source
  -- spans. -garyb
  SimpleErrorMessage -> SourceSpan -> SourceSpan
getSpan (ErrorMessage -> SimpleErrorMessage
unwrapErrorMessage ErrorMessage
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NEL.head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorMessage -> Maybe (NonEmpty SourceSpan)
errorSpan ErrorMessage
e
  where
    startOnly :: SourceSpan -> SourceSpan
startOnly SourceSpan{FilePath
spanName :: SourceSpan -> FilePath
spanName :: FilePath
spanName, SourcePos
spanStart :: SourceSpan -> SourcePos
spanStart :: SourcePos
spanStart} = SourceSpan {FilePath
spanName :: FilePath
spanName :: FilePath
spanName, SourcePos
spanStart :: SourcePos
spanStart :: SourcePos
spanStart, spanEnd :: SourcePos
spanEnd = SourcePos
spanStart}

    getSpan :: SimpleErrorMessage -> SourceSpan -> SourceSpan
getSpan SimpleErrorMessage
simple SourceSpan
ss =
      case SimpleErrorMessage
simple of
        MissingTypeDeclaration{} -> SourceSpan -> SourceSpan
startOnly SourceSpan
ss
        MissingKindDeclaration{} -> SourceSpan -> SourceSpan
startOnly SourceSpan
ss
        SimpleErrorMessage
_ -> SourceSpan
ss

showSuggestion :: SimpleErrorMessage -> Text
showSuggestion :: SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
suggestion = case SimpleErrorMessage -> Maybe ErrorSuggestion
errorSuggestion SimpleErrorMessage
suggestion of
  Just (ErrorSuggestion Text
x) -> Text
x
  Maybe ErrorSuggestion
_ -> Text
""

ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String
ansiColor :: (ColorIntensity, Color) -> FilePath
ansiColor (ColorIntensity
intensity, Color
color) =
   [SGR] -> FilePath
ANSI.setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
intensity Color
color]

ansiColorReset :: String
ansiColorReset :: FilePath
ansiColorReset =
   [SGR] -> FilePath
ANSI.setSGRCode [SGR
ANSI.Reset]

colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Text -> Text
colorCode :: Maybe (ColorIntensity, Color) -> Text -> Text
colorCode Maybe (ColorIntensity, Color)
codeColor Text
code = case Maybe (ColorIntensity, Color)
codeColor of
  Maybe (ColorIntensity, Color)
Nothing -> Text
code
  Just (ColorIntensity, Color)
cc -> FilePath -> Text
T.pack ((ColorIntensity, Color) -> FilePath
ansiColor (ColorIntensity, Color)
cc) forall a. Semigroup a => a -> a -> a
<> Text
code forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
ansiColorReset

colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box
colorCodeBox :: Maybe (ColorIntensity, Color) -> Box -> Box
colorCodeBox Maybe (ColorIntensity, Color)
codeColor Box
b = case Maybe (ColorIntensity, Color)
codeColor of
  Maybe (ColorIntensity, Color)
Nothing -> Box
b
  Just (ColorIntensity, Color)
cc
    | Box -> Int
Box.rows Box
b forall a. Eq a => a -> a -> Bool
== Int
1 ->
        FilePath -> Box
Box.text ((ColorIntensity, Color) -> FilePath
ansiColor (ColorIntensity, Color)
cc) Box -> Box -> Box
Box.<> Box
b Box -> Box -> Box
`endWith` FilePath -> Box
Box.text FilePath
ansiColorReset

    | Bool
otherwise -> forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.hcat Alignment
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
        [ forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.top forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Box -> Int
Box.rows Box
b) forall a b. (a -> b) -> a -> b
$ FilePath -> Box
Box.text forall a b. (a -> b) -> a -> b
$ (ColorIntensity, Color) -> FilePath
ansiColor (ColorIntensity, Color)
cc
        , Box
b
        , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.top forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Box -> Int
Box.rows Box
b) forall a b. (a -> b) -> a -> b
$ FilePath -> Box
Box.text FilePath
ansiColorReset
        ]

commasAndConjunction :: Text -> [Text] -> Text
commasAndConjunction :: Text -> [Text] -> Text
commasAndConjunction Text
conj = \case
  [Text
x] -> Text
x
  [Text
x, Text
y] -> Text
x forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
conj forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
y
  (forall x. [x] -> Maybe ([x], x)
unsnoc -> Just ([Text]
rest, Text
z)) -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Semigroup a => a -> a -> a
<> Text
", ") [Text]
rest forall a. Semigroup a => a -> a -> a
<> Text
conj forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
z
  [Text]
_ -> Text
""

-- | Default color intensity and color for code
defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color)
defaultCodeColor :: (ColorIntensity, Color)
defaultCodeColor = (ColorIntensity
ANSI.Dull, Color
ANSI.Yellow)

-- | `prettyPrintSingleError` Options
data PPEOptions = PPEOptions
  { PPEOptions -> Maybe (ColorIntensity, Color)
ppeCodeColor         :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not
  , PPEOptions -> Bool
ppeFull              :: Bool -- ^ Should write a full error message?
  , PPEOptions -> Level
ppeLevel             :: Level -- ^ Should this report an error or a warning?
  , PPEOptions -> Bool
ppeShowDocs          :: Bool -- ^ Should show a link to error message's doc page?
  , PPEOptions -> FilePath
ppeRelativeDirectory :: FilePath -- ^ FilePath to which the errors are relative
  , PPEOptions -> [(FilePath, Text)]
ppeFileContents      :: [(FilePath, Text)] -- ^ Unparsed contents of source files
  }

-- | Default options for PPEOptions
defaultPPEOptions :: PPEOptions
defaultPPEOptions :: PPEOptions
defaultPPEOptions = PPEOptions
  { ppeCodeColor :: Maybe (ColorIntensity, Color)
ppeCodeColor         = forall a. a -> Maybe a
Just (ColorIntensity, Color)
defaultCodeColor
  , ppeFull :: Bool
ppeFull              = Bool
False
  , ppeLevel :: Level
ppeLevel             = Level
Error
  , ppeShowDocs :: Bool
ppeShowDocs          = Bool
True
  , ppeRelativeDirectory :: FilePath
ppeRelativeDirectory = forall a. Monoid a => a
mempty
  , ppeFileContents :: [(FilePath, Text)]
ppeFileContents      = []
  }

-- | Pretty print a single error, simplifying if necessary
prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box
prettyPrintSingleError (PPEOptions Maybe (ColorIntensity, Color)
codeColor Bool
full Level
level Bool
showDocs FilePath
relPath [(FilePath, Text)]
fileContents) ErrorMessage
e = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState TypeMap
defaultUnknownMap forall a b. (a -> b) -> a -> b
$ do
  ErrorMessage
em <- forall (m :: * -> *).
Applicative m =>
(Type SourceAnn -> m (Type SourceAnn))
-> ErrorMessage -> m ErrorMessage
onTypesInErrorMessageM Type SourceAnn -> State TypeMap (Type SourceAnn)
replaceUnknowns (if Bool
full then ErrorMessage
e else ErrorMessage -> ErrorMessage
simplifyErrorMessage ErrorMessage
e)
  TypeMap
um <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap -> ErrorMessage -> Box
prettyPrintErrorMessage TypeMap
um ErrorMessage
em)
  where
  (Text -> Text
markCode, Box -> Box
markCodeBox) = (Maybe (ColorIntensity, Color) -> Text -> Text
colorCode forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Maybe (ColorIntensity, Color) -> Box -> Box
colorCodeBox) Maybe (ColorIntensity, Color)
codeColor

  -- Pretty print an ErrorMessage
  prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
  prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box
prettyPrintErrorMessage TypeMap
typeMap (ErrorMessage [ErrorMessageHint]
hints SimpleErrorMessage
simple) =
    forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
      [ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ErrorMessageHint -> Box -> Box
renderHint (Box -> Box
indent (SimpleErrorMessage -> Box
renderSimpleErrorMessage SimpleErrorMessage
simple)) [ErrorMessageHint]
hints
      ] forall a. [a] -> [a] -> [a]
++
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Box -> Box
Box.moveDown Int
1) Maybe Box
typeInformation forall a. [a] -> [a] -> [a]
++
      [ Int -> Box -> Box
Box.moveDown Int
1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras
          [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"See " forall a. Semigroup a => a -> a -> a
<> ErrorMessage -> Text
errorDocUri ErrorMessage
e forall a. Semigroup a => a -> a -> a
<> Text
" for more information, "
          , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"or to contribute content related to this " forall a. Semigroup a => a -> a -> a
<> Text
levelText forall a. Semigroup a => a -> a -> a
<> Text
"."
          ]
      | Bool
showDocs
      ]
    where
    typeInformation :: Maybe Box.Box
    typeInformation :: Maybe Box
typeInformation | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Box]
types) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left [ Text -> Box
line Text
"where", forall (f :: * -> *). Foldable f => f Box -> Box
paras [Box]
types ]
                    | Bool
otherwise = forall a. Maybe a
Nothing
      where
      types :: [Box.Box]
      types :: [Box]
types = forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Int, Maybe SourceSpan) -> Box
skolemInfo  (forall k a. Map k a -> [a]
M.elems (TypeMap -> Map Int (FilePath, Int, Maybe SourceSpan)
umSkolemMap TypeMap
typeMap)) forall a. [a] -> [a] -> [a]
++
              forall a b. (a -> b) -> [a] -> [b]
map Int -> Box
unknownInfo (forall k a. Map k a -> [a]
M.elems (TypeMap -> Map Int Int
umUnknownMap TypeMap
typeMap))

      skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box
      skolemInfo :: (FilePath, Int, Maybe SourceSpan) -> Box
skolemInfo (FilePath
name, Int
s, Maybe SourceSpan
ss) =
        forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
          Text -> Box
line (Text -> Text
markCode (FilePath -> Text
T.pack (FilePath
name forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
s)) forall a. Semigroup a => a -> a -> a
<> Text
" is a rigid type variable")
          forall a. a -> [a] -> [a]
: forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"  bound at " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> Text
displayStartEndPos) Maybe SourceSpan
ss

      unknownInfo :: Int -> Box.Box
      unknownInfo :: Int -> Box
unknownInfo Int
u = Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode (Text
"t" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
u)) forall a. Semigroup a => a -> a -> a
<> Text
" is an unknown type"

    renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
    renderSimpleErrorMessage :: SimpleErrorMessage -> Box
renderSimpleErrorMessage (InternalCompilerError Text
ctx Text
err) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Internal compiler error:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line Text
err
            , Text -> Box
line Text
ctx
            , Text -> Box
line Text
"Please report this at https://github.com/purescript/purescript/issues"
            ]
    renderSimpleErrorMessage (ModuleNotFound ModuleName
mn) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" was not found."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$
                if ModuleName -> Bool
isBuiltinModuleName ModuleName
mn
                  then
                    Text
"Module names in the Prim namespace are reserved for built-in modules, but this version of the compiler does not provide module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
". You may be able to fix this by updating your compiler to a newer version."
                  else
                    Text
"Make sure the source file exists, and that it has been provided as an input to the compiler."
            ]
    renderSimpleErrorMessage (FileIOError Text
doWhat IOError
err) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"I/O error while trying to " forall a. Semigroup a => a -> a -> a
<> Text
doWhat
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Box
lineS forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException IOError
err
            ]
    renderSimpleErrorMessage (ErrorParsingFFIModule FilePath
path Maybe ErrorMessage
extra) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ [ Text -> Box
line Text
"Unable to parse foreign module:"
              , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Box
lineS forall a b. (a -> b) -> a -> b
$ FilePath
path
              ] forall a. [a] -> [a] -> [a]
++
              forall a b. (a -> b) -> [a] -> [b]
map (Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Box
lineS) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ErrorMessage -> [FilePath]
Bundle.printErrorMessage (forall a. Maybe a -> [a]
maybeToList Maybe ErrorMessage
extra))
    renderSimpleErrorMessage (ErrorParsingCSTModule ParserError
err) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Unable to parse module: "
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ParserError -> FilePath
CST.prettyPrintErrorMessage ParserError
err
            ]
    renderSimpleErrorMessage (WarningParsingCSTModule ParserWarning
err) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ParserWarning -> FilePath
CST.prettyPrintWarningMessage ParserWarning
err
            ]
    renderSimpleErrorMessage (MissingFFIModule ModuleName
mn) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The foreign module implementation for module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" is missing."
    renderSimpleErrorMessage (UnnecessaryFFIModule ModuleName
mn FilePath
path) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"An unnecessary foreign module implementation was provided for module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
": "
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Box
lineS forall a b. (a -> b) -> a -> b
$ FilePath
path
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" does not contain any foreign import declarations, so a foreign module is not necessary."
            ]
    renderSimpleErrorMessage (MissingFFIImplementations ModuleName
mn [Ident]
idents) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The following values are not defined in the foreign module for module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
": "
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
runIdent) [Ident]
idents
            ]
    renderSimpleErrorMessage (UnusedFFIImplementations ModuleName
mn [Ident]
idents) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The following definitions in the foreign module for module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" are unused: "
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
runIdent) [Ident]
idents
            ]
    renderSimpleErrorMessage (InvalidFFIIdentifier ModuleName
mn Text
ident) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"In the FFI module for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
":"
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
                [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The identifier " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
ident forall a. Semigroup a => a -> a -> a
<> Text
" is not valid in PureScript."
                , Text -> Box
line Text
"Note that exported identifiers in FFI modules must be valid PureScript identifiers."
                ]
            ]
    renderSimpleErrorMessage (DeprecatedFFIPrime ModuleName
mn Text
ident) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"In the FFI module for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
":"
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
                [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The identifier " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
ident forall a. Semigroup a => a -> a -> a
<> Text
" contains a prime (" forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
")."
                , Text -> Box
line Text
"Primes are not allowed in identifiers exported from FFI modules."
                ]
            ]
    renderSimpleErrorMessage (DeprecatedFFICommonJSModule ModuleName
mn FilePath
path) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"A CommonJS foreign module implementation was provided for module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
": "
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Box
lineS forall a b. (a -> b) -> a -> b
$ FilePath
path
            , Text -> Box
line Text
"CommonJS foreign modules are no longer supported. Use native JavaScript/ECMAScript module syntax instead."
            ]
    renderSimpleErrorMessage (UnsupportedFFICommonJSExports ModuleName
mn [Text]
idents) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The following CommonJS exports are not supported in the ES foreign module for module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
": "
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Box
line [Text]
idents
            ]
    renderSimpleErrorMessage (UnsupportedFFICommonJSImports ModuleName
mn [Text]
mids) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The following CommonJS imports are not supported in the ES foreign module for module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
": "
            , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Box
line [Text]
mids
            ]
    renderSimpleErrorMessage SimpleErrorMessage
InvalidDoBind =
      Text -> Box
line Text
"The last statement in a 'do' block must be an expression, but this block ends with a binder."
    renderSimpleErrorMessage SimpleErrorMessage
InvalidDoLet =
      Text -> Box
line Text
"The last statement in a 'do' block must be an expression, but this block ends with a let binding."
    renderSimpleErrorMessage (OverlappingNamesInLet Ident
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The name " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
name) forall a. Semigroup a => a -> a -> a
<> Text
" was defined multiple times in a binding group"
    renderSimpleErrorMessage (InfiniteType Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"An infinite type was inferred for an expression: "
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            ]
    renderSimpleErrorMessage (InfiniteKind Type SourceAnn
ki) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"An infinite kind was inferred for a type: "
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ki
            ]
    renderSimpleErrorMessage (MultipleValueOpFixities OpName 'ValueOpName
op) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"There are multiple fixity/precedence declarations for operator " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: OpNameType). OpName a -> Text
showOp OpName 'ValueOpName
op)
    renderSimpleErrorMessage (MultipleTypeOpFixities OpName 'TypeOpName
op) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"There are multiple fixity/precedence declarations for type operator " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: OpNameType). OpName a -> Text
showOp OpName 'TypeOpName
op)
    renderSimpleErrorMessage (OrphanTypeDeclaration Ident
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The type declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
nm) forall a. Semigroup a => a -> a -> a
<> Text
" should be followed by its definition."
    renderSimpleErrorMessage (OrphanKindDeclaration ProperName 'TypeName
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The kind declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
nm) forall a. Semigroup a => a -> a -> a
<> Text
" should be followed by its definition."
    renderSimpleErrorMessage (OrphanRoleDeclaration ProperName 'TypeName
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The role declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
nm) forall a. Semigroup a => a -> a -> a
<> Text
" should follow its definition."
    renderSimpleErrorMessage (RedefinedIdent Ident
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The value " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
name) forall a. Semigroup a => a -> a -> a
<> Text
" has been defined multiple times"
    renderSimpleErrorMessage (UnknownName name :: Qualified Name
name@(Qualified (BySourcePos SourcePos
_) (IdentName (Ident Text
i)))) | Text
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ forall a. (Eq a, IsString a) => a
C.S_bind, forall a. (Eq a, IsString a) => a
C.S_discard ] =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Unknown " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName Qualified Name
name forall a. Semigroup a => a -> a -> a
<> Text
". You're probably using do-notation, which the compiler replaces with calls to the " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"bind" forall a. Semigroup a => a -> a -> a
<> Text
" and " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"discard" forall a. Semigroup a => a -> a -> a
<> Text
" functions. Please import " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
i forall a. Semigroup a => a -> a -> a
<> Text
" from module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"Prelude"
    renderSimpleErrorMessage (UnknownName name :: Qualified Name
name@(Qualified (BySourcePos SourcePos
_) (IdentName (Ident Text
C.S_negate)))) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Unknown " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName Qualified Name
name forall a. Semigroup a => a -> a -> a
<> Text
". You're probably using numeric negation (the unary " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
" operator), which the compiler replaces with calls to the " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode forall a. (Eq a, IsString a) => a
C.S_negate forall a. Semigroup a => a -> a -> a
<> Text
" function. Please import " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode forall a. (Eq a, IsString a) => a
C.S_negate forall a. Semigroup a => a -> a -> a
<> Text
" from module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"Prelude"
    renderSimpleErrorMessage (UnknownName Qualified Name
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Unknown " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName Qualified Name
name
    renderSimpleErrorMessage (UnknownImport ModuleName
mn Name
name) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Cannot import " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Name
name) forall a. Semigroup a => a -> a -> a
<> Text
" from module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn)
            , Text -> Box
line Text
"It either does not exist or the module does not export it."
            ]
    renderSimpleErrorMessage (UnknownImportDataConstructor ModuleName
mn ProperName 'TypeName
tcon ProperName 'ConstructorName
dcon) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
runModuleName ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
" does not export data constructor " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'ConstructorName
dcon) forall a. Semigroup a => a -> a -> a
<> Text
" for type " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
tcon)
    renderSimpleErrorMessage (UnknownExport Name
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Cannot export unknown " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Name
name)
    renderSimpleErrorMessage (UnknownExportDataConstructor ProperName 'TypeName
tcon ProperName 'ConstructorName
dcon) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Cannot export data constructor " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'ConstructorName
dcon) forall a. Semigroup a => a -> a -> a
<> Text
" for type " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
tcon) forall a. Semigroup a => a -> a -> a
<> Text
", as it has not been declared."
    renderSimpleErrorMessage (ScopeConflict Name
nm [ModuleName]
ms) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Conflicting definitions are in scope for " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Name
nm) forall a. Semigroup a => a -> a -> a
<> Text
" from the following modules:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
runModuleName) [ModuleName]
ms
            ]
    renderSimpleErrorMessage (ScopeShadowing Name
nm Maybe ModuleName
exmn [ModuleName]
ms) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Shadowed definitions are in scope for " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Name
nm) forall a. Semigroup a => a -> a -> a
<> Text
" from the following open imports:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"import " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
runModuleName) [ModuleName]
ms
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"These will be ignored and the " forall a. Semigroup a => a -> a -> a
<> case Maybe ModuleName
exmn of
                Just ModuleName
exmn' -> Text
"declaration from " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
exmn') forall a. Semigroup a => a -> a -> a
<> Text
" will be used."
                Maybe ModuleName
Nothing -> Text
"local declaration will be used."
            ]
    renderSimpleErrorMessage (DeclConflict Name
new Name
existing) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Declaration for " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Name
new) forall a. Semigroup a => a -> a -> a
<> Text
" conflicts with an existing " forall a. Semigroup a => a -> a -> a
<> Name -> Text
nameType Name
existing forall a. Semigroup a => a -> a -> a
<> Text
" of the same name."
    renderSimpleErrorMessage (ExportConflict Qualified Name
new Qualified Name
existing) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Export for " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName Qualified Name
new forall a. Semigroup a => a -> a -> a
<> Text
" conflicts with " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName Qualified Name
existing
    renderSimpleErrorMessage (DuplicateModule ModuleName
mn) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" has been defined multiple times"
    renderSimpleErrorMessage (DuplicateTypeClass ProperName 'ClassName
pn SourceSpan
ss) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line (Text
"Type class " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'ClassName
pn) forall a. Semigroup a => a -> a -> a
<> Text
" has been defined multiple times:")
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ FilePath -> SourceSpan -> Text
displaySourceSpan FilePath
relPath SourceSpan
ss
            ]
    renderSimpleErrorMessage (DuplicateInstance Ident
pn SourceSpan
ss) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line (Text
"Instance " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
pn) forall a. Semigroup a => a -> a -> a
<> Text
" has been defined multiple times:")
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ FilePath -> SourceSpan -> Text
displaySourceSpan FilePath
relPath SourceSpan
ss
            ]
    renderSimpleErrorMessage (CycleInDeclaration Ident
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The value of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
nm) forall a. Semigroup a => a -> a -> a
<> Text
" is undefined here, so this reference is not allowed."
    renderSimpleErrorMessage (CycleInModules NonEmpty ModuleName
mns) =
      case NonEmpty ModuleName
mns of
        ModuleName
mn :| [] ->
          Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" imports itself."
        NonEmpty ModuleName
_ ->
          forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"There is a cycle in module dependencies in these modules: "
                , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
runModuleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NEL.toList NonEmpty ModuleName
mns)
                ]
    renderSimpleErrorMessage (CycleInTypeSynonym NonEmpty (ProperName 'TypeName)
names) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ [Box]
cycleError forall a. Semigroup a => a -> a -> a
<>
            [ Text -> Box
line Text
"Cycles are disallowed because they can lead to loops in the type checker."
            , Text -> Box
line Text
"Consider using a 'newtype' instead."
            ]
      where
      cycleError :: [Box]
cycleError = case NonEmpty (ProperName 'TypeName)
names of
        ProperName 'TypeName
pn :| [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"A cycle appears in the definition of type synonym " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
pn)
        NonEmpty (ProperName 'TypeName)
_ -> [ Text -> Box
line Text
" A cycle appears in a set of type synonym definitions:"
             , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"{" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
runProperName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (ProperName 'TypeName)
names) forall a. Semigroup a => a -> a -> a
<> Text
"}"
             ]
    renderSimpleErrorMessage (CycleInTypeClassDeclaration (Qualified (ProperName 'ClassName)
name :| [])) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"A type class '" forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName (forall a. Qualified a -> a
disqualify Qualified (ProperName 'ClassName)
name)) forall a. Semigroup a => a -> a -> a
<> Text
"' may not have itself as a superclass." ]
    renderSimpleErrorMessage (CycleInTypeClassDeclaration NonEmpty (Qualified (ProperName 'ClassName))
names) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"A cycle appears in a set of type class definitions:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"{" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
runProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> a
disqualify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Qualified (ProperName 'ClassName))
names) forall a. Semigroup a => a -> a -> a
<> Text
"}"
            , Text -> Box
line Text
"Cycles are disallowed because they can lead to loops in the type checker."
            ]
    renderSimpleErrorMessage (CycleInKindDeclaration (Qualified (ProperName 'TypeName)
name :| [])) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"A kind declaration '" forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName (forall a. Qualified a -> a
disqualify Qualified (ProperName 'TypeName)
name)) forall a. Semigroup a => a -> a -> a
<> Text
"' may not refer to itself in its own signature." ]
    renderSimpleErrorMessage (CycleInKindDeclaration NonEmpty (Qualified (ProperName 'TypeName))
names) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"A cycle appears in a set of kind declarations:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"{" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
runProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> a
disqualify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Qualified (ProperName 'TypeName))
names) forall a. Semigroup a => a -> a -> a
<> Text
"}"
            , Text -> Box
line Text
"Kind declarations may not refer to themselves in their own signatures."
            ]
    renderSimpleErrorMessage (NameIsUndefined Ident
ident) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Value " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident) forall a. Semigroup a => a -> a -> a
<> Text
" is undefined."
    renderSimpleErrorMessage (UndefinedTypeVariable ProperName 'TypeName
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name) forall a. Semigroup a => a -> a -> a
<> Text
" is undefined."
    renderSimpleErrorMessage (PartiallyAppliedSynonym Qualified (ProperName 'TypeName)
name) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Type synonym " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'TypeName)
name) forall a. Semigroup a => a -> a -> a
<> Text
" is partially applied."
            , Text -> Box
line Text
"Type synonyms must be applied to all of their type arguments."
            ]
    renderSimpleErrorMessage (EscapedSkolem Text
name Maybe SourceSpan
Nothing Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
name forall a. Semigroup a => a -> a -> a
<> Text
" has escaped its scope, appearing in the type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            ]
    renderSimpleErrorMessage (EscapedSkolem Text
name (Just SourceSpan
srcSpan) Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
name forall a. Semigroup a => a -> a -> a
<> Text
", bound at"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ FilePath -> SourceSpan -> Text
displaySourceSpan FilePath
relPath SourceSpan
srcSpan
            , Text -> Box
line Text
"has escaped its scope, appearing in the type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            ]
    renderSimpleErrorMessage (TypesDoNotUnify Type SourceAnn
u1 Type SourceAnn
u2)
      = let (Box
row1Box, Box
row2Box) = forall a. Type a -> Type a -> (Box, Box)
printRows Type SourceAnn
u1 Type SourceAnn
u2

        in forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Could not match type"
                 , Box
row1Box
                 , Text -> Box
line Text
"with type"
                 , Box
row2Box
                 ]

    renderSimpleErrorMessage (KindsDoNotUnify Type SourceAnn
k1 Type SourceAnn
k2) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Could not match kind"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
k1
            , Text -> Box
line Text
"with kind"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
k2
            ]
    renderSimpleErrorMessage (ConstrainedTypeUnified Type SourceAnn
t1 Type SourceAnn
t2) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Could not match constrained type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
t1
            , Text -> Box
line Text
"with type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
t2
            ]
    renderSimpleErrorMessage (OverlappingInstances Qualified (ProperName 'ClassName)
_ [Type SourceAnn]
_ []) = forall a. HasCallStack => FilePath -> a
internalError FilePath
"OverlappingInstances: empty instance list"
    renderSimpleErrorMessage (OverlappingInstances Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
ts [Qualified (Either (Type SourceAnn) Ident)]
ds) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Overlapping type class instances found for"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Text -> Box
line Text
"The following instances were found:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras (forall a b. (a -> b) -> [a] -> [b]
map Qualified (Either (Type SourceAnn) Ident) -> Box
prettyInstanceName [Qualified (Either (Type SourceAnn) Ident)]
ds)
            ]
    renderSimpleErrorMessage (UnknownClass Qualified (ProperName 'ClassName)
nm) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"No type class instance was found for class"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
            , Text -> Box
line Text
"because the class was not in scope. Perhaps it was not exported."
            ]
    renderSimpleErrorMessage (NoInstanceFound (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
C.Fail [Type SourceAnn]
_ [ Type SourceAnn
ty ] Maybe ConstraintData
_) [Qualified (Either (Type SourceAnn) Ident)]
_ UnknownsHint
_) | Just Box
box <- forall a. Type a -> Maybe Box
toTypelevelString Type SourceAnn
ty =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Custom error:"
            , Box -> Box
indent Box
box
            ]
    renderSimpleErrorMessage (NoInstanceFound (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
C.Partial
                                                          [Type SourceAnn]
_
                                                          [Type SourceAnn]
_
                                                          (Just (PartialConstraintData [[Text]]
bs Bool
b))) [Qualified (Either (Type SourceAnn) Ident)]
_ UnknownsHint
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"A case expression could not be determined to cover all inputs."
            , Text -> Box
line Text
"The following additional cases are required to cover all inputs:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
                forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                  (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *). Foldable f => f Box -> Box
paras forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode)) (forall a. [[a]] -> [[a]]
transpose [[Text]]
bs))
                  forall a. a -> [a] -> [a]
: [Text -> Box
line Text
"..." | Bool -> Bool
not Bool
b]
            , Text -> Box
line Text
"Alternatively, add a Partial constraint to the type of the enclosing value."
            ]
    renderSimpleErrorMessage (NoInstanceFound (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
C.Discard [Type SourceAnn]
_ [Type SourceAnn
ty] Maybe ConstraintData
_) [Qualified (Either (Type SourceAnn) Ident)]
_ UnknownsHint
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"A result of type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            , Text -> Box
line Text
"was implicitly discarded in a do notation block."
            , Text -> Box
line (Text
"You can use " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"_ <- ..." forall a. Semigroup a => a -> a -> a
<> Text
" to explicitly discard the result.")
            ]
    renderSimpleErrorMessage (NoInstanceFound (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
_ [Type SourceAnn]
ts Maybe ConstraintData
_) [Qualified (Either (Type SourceAnn) Ident)]
ambiguous UnknownsHint
unks) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
            [ Text -> Box
line Text
"No type class instance was found for"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ let useMessage :: Text -> [Box]
useMessage Text
msg =
                            [ Text -> Box
line Text
msg
                            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras (forall a b. (a -> b) -> [a] -> [b]
map Qualified (Either (Type SourceAnn) Ident) -> Box
prettyInstanceName [Qualified (Either (Type SourceAnn) Ident)]
ambiguous)
                            ]
                      in case [Qualified (Either (Type SourceAnn) Ident)]
ambiguous of
                        [] -> []
                        [Qualified (Either (Type SourceAnn) Ident)
_] -> Text -> [Box]
useMessage Text
"The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered:"
                        [Qualified (Either (Type SourceAnn) Ident)]
_ -> Text -> [Box]
useMessage Text
"The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered:"
            ] forall a. Semigroup a => a -> a -> a
<> case UnknownsHint
unks of
                  UnknownsHint
NoUnknowns ->
                    []
                  UnknownsHint
Unknowns ->
                    [ Text -> Box
line Text
"The instance head contains unknown type variables. Consider adding a type annotation." ]
                  UnknownsWithVtaRequiringArgs NonEmpty (Qualified Ident, [[Text]])
tyClassMembersRequiringVtas ->
                    let
                      renderSingleTyClassMember :: (Qualified Ident, [[Text]]) -> Box
renderSingleTyClassMember (Qualified Ident
tyClassMember, [[Text]]
argsRequiringVtas) =
                        Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
                          [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
showIdent Qualified Ident
tyClassMember) ]
                          forall a. Semigroup a => a -> a -> a
<> case [[Text]]
argsRequiringVtas of
                              [[Text]
required] ->
                                [ Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " [Text]
required ]
                              [[Text]]
options -> 
                                [ Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ Text -> Box
line Text
"One of the following sets of type variables:"
                                , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
                                    forall a b. (a -> b) -> [a] -> [b]
map (\[Text]
set -> Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " [Text]
set) [[Text]]
options
                                ]
                    in
                      [ forall (f :: * -> *). Foldable f => f Box -> Box
paras
                        [ Text -> Box
line Text
"The instance head contains unknown type variables."
                        , Int -> Box -> Box
Box.moveDown Int
1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$
                            [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"tyClassMember @Int" forall a. Semigroup a => a -> a -> a
<> Text
")."]
                            forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (Qualified Ident, [[Text]]) -> Box
renderSingleTyClassMember (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Qualified Ident, [[Text]])
tyClassMembersRequiringVtas)
                        ]
                      ]
    renderSimpleErrorMessage (AmbiguousTypeVariables Type SourceAnn
t [(Text, Int)]
uis) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"The inferred type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
t
            , Text -> Box
line Text
"has type variables which are not determined by those mentioned in the body of the type:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
              [ forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left
                [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode (Text
u forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
i)) forall a. Semigroup a => a -> a -> a
<> Text
" could not be determined"
                | (Text
u, Int
i) <- [(Text, Int)]
uis ]
              ]
            , Text -> Box
line Text
"Consider adding a type annotation."
            ]
    renderSimpleErrorMessage (PossiblyInfiniteInstance Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
ts) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Type class instance for"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Text -> Box
line Text
"is possibly infinite."
            ]
    renderSimpleErrorMessage SimpleErrorMessage
PossiblyInfiniteCoercibleInstance =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"A " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"Coercible" forall a. Semigroup a => a -> a -> a
<> Text
" instance is possibly infinite."
    renderSimpleErrorMessage (CannotDerive Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
ts) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Cannot derive a type class instance for"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Text -> Box
line Text
"since instances of this type class are not derivable."
            ]
    renderSimpleErrorMessage (InvalidNewtypeInstance Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
ts) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Cannot derive newtype instance for"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Text -> Box
line Text
"Make sure this is a newtype."
            ]
    renderSimpleErrorMessage (MissingNewtypeSuperclassInstance Qualified (ProperName 'ClassName)
su Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"The derived newtype instance for"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
cl)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"does not include a derived superclass instance for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
su) forall a. Semigroup a => a -> a -> a
<> Text
"."
            ]
    renderSimpleErrorMessage (UnverifiableSuperclassInstance Qualified (ProperName 'ClassName)
su Qualified (ProperName 'ClassName)
cl [Type SourceAnn]
ts) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"The derived newtype instance for"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
cl)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"implies an superclass instance for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
su) forall a. Semigroup a => a -> a -> a
<> Text
" which could not be verified."
            ]
    renderSimpleErrorMessage (InvalidDerivedInstance Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
ts Int
argCount) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Cannot derive the type class instance"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
                [ Text
"because the "
                , Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , Text
" type class has "
                , FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
argCount)
                , Text
" type "
                , if Int
argCount forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"argument" else Text
"arguments"
                , Text
", but the declaration specifies " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type SourceAnn]
ts)) forall a. Semigroup a => a -> a -> a
<> Text
"."
                ]
            ]
    renderSimpleErrorMessage (ExpectedTypeConstructor Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
ts Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Cannot derive the type class instance"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , Box
"because the type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            , Text -> Box
line Text
"is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module."
            ]
    renderSimpleErrorMessage (CannotFindDerivingType ProperName 'TypeName
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Cannot derive a type class instance, because the type declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
nm) forall a. Semigroup a => a -> a -> a
<> Text
" could not be found."
    renderSimpleErrorMessage (DuplicateLabel Label
l Maybe Expr
expr) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Label " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Label -> Text
prettyPrintLabel Label
l) forall a. Semigroup a => a -> a -> a
<> Text
" appears more than once in a row type." ]
                       forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Expr
expr' -> [ Text -> Box
line Text
"Relevant expression: "
                                             , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth Expr
expr'
                                             ]) Maybe Expr
expr
    renderSimpleErrorMessage (DuplicateTypeArgument Text
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Type argument " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
name forall a. Semigroup a => a -> a -> a
<> Text
" appears more than once."
    renderSimpleErrorMessage (DuplicateValueDeclaration Ident
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Multiple value declarations exist for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
nm) forall a. Semigroup a => a -> a -> a
<> Text
"."
    renderSimpleErrorMessage (ArgListLengthsDiffer Ident
ident) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Argument list lengths differ in declaration " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident)
    renderSimpleErrorMessage (OverlappingArgNames Maybe Ident
ident) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Overlapping names in function/binder" forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Text
" in declaration " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
showIdent) Maybe Ident
ident
    renderSimpleErrorMessage (MissingClassMember NonEmpty (Ident, Type SourceAnn)
identsAndTypes) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"The following type class members have not been implemented:"
            , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left
              [ Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ FilePath -> Box
Box.text (Text -> FilePath
T.unpack (Ident -> Text
showIdent Ident
ident)) Box -> Box -> Box
Box.<> Box
" :: " Box -> Box -> Box
Box.<> forall a. Type a -> Box
prettyType Type SourceAnn
ty
              | (Ident
ident, Type SourceAnn
ty) <- forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Ident, Type SourceAnn)
identsAndTypes ]
            ]
    renderSimpleErrorMessage (ExtraneousClassMember Ident
ident Qualified (ProperName 'ClassName)
className) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"" forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident) forall a. Semigroup a => a -> a -> a
<> Text
" is not a member of type class " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
className)
    renderSimpleErrorMessage (ExpectedType Type SourceAnn
ty Type SourceAnn
kind) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"In a type-annotated expression " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"x :: t" forall a. Semigroup a => a -> a -> a
<> Text
", the type " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"t" forall a. Semigroup a => a -> a -> a
<> Text
" must have kind " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> a
disqualify forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'TypeName)
C.Type) forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text -> Box
line Text
"The error arises from the type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            , Text -> Box
line Text
"having the kind"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
kind
            , Text -> Box
line Text
"instead."
            ]
    renderSimpleErrorMessage (IncorrectConstructorArity Qualified (ProperName 'ConstructorName)
nm Int
expected Int
actual) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Data constructor " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ConstructorName)
nm) forall a. Semigroup a => a -> a -> a
<> Text
" was given " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
actual) forall a. Semigroup a => a -> a -> a
<> Text
" arguments in a case expression, but expected " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
expected) forall a. Semigroup a => a -> a -> a
<> Text
" arguments."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"This problem can be fixed by giving " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ConstructorName)
nm) forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
expected) forall a. Semigroup a => a -> a -> a
<> Text
" arguments."
            ]
    renderSimpleErrorMessage (ExprDoesNotHaveType Expr
expr Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Expression"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth Expr
expr
            , Text -> Box
line Text
"does not have type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            ]
    renderSimpleErrorMessage (PropertyIsMissing Label
prop) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Type of expression lacks required label " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Label -> Text
prettyPrintLabel Label
prop) forall a. Semigroup a => a -> a -> a
<> Text
"."
    renderSimpleErrorMessage (AdditionalProperty Label
prop) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Type of expression contains additional label " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Label -> Text
prettyPrintLabel Label
prop) forall a. Semigroup a => a -> a -> a
<> Text
"."
    renderSimpleErrorMessage (OrphanInstance Ident
nm Qualified (ProperName 'ClassName)
cnm Set ModuleName
nonOrphanModules [Type SourceAnn]
ts) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Orphan instance" forall a. Semigroup a => a -> a -> a
<> Ident -> Text
prettyPrintPlainIdent Ident
nm forall a. Semigroup a => a -> a -> a
<> Text
" found for "
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
cnm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
ts)
                ]
            , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left forall a b. (a -> b) -> a -> b
$ case [ModuleName]
modulesToList of
                [] -> [ Text -> Box
line Text
"There is nowhere this instance can be placed without being an orphan."
                      , Text -> Box
line Text
"A newtype wrapper can be used to avoid this problem."
                      ]
                [ModuleName]
_  -> [ FilePath -> Box
Box.text forall a b. (a -> b) -> a -> b
$ FilePath
"This problem can be resolved by declaring the instance in "
                          forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
formattedModules
                          forall a. Semigroup a => a -> a -> a
<> FilePath
", or by defining the instance on a newtype wrapper."
                      ]
                ]
      where
        modulesToList :: [ModuleName]
modulesToList = forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
S.delete (Text -> ModuleName
moduleNameFromString Text
"Prim") Set ModuleName
nonOrphanModules
        formattedModules :: Text
formattedModules = Text -> [Text] -> Text
T.intercalate Text
" or " (Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
runModuleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
modulesToList)
    renderSimpleErrorMessage (InvalidNewtype ProperName 'TypeName
name) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Newtype " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name) forall a. Semigroup a => a -> a -> a
<> Text
" is invalid."
            , Text -> Box
line Text
"Newtypes must define a single constructor with a single argument."
            ]
    renderSimpleErrorMessage (InvalidInstanceHead Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Type class instance head is invalid due to use of type"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            , Text -> Box
line Text
"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."
            ]
    renderSimpleErrorMessage (TransitiveExportError DeclarationRef
x [DeclarationRef]
ys) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"An export for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (DeclarationRef -> Text
prettyPrintExport DeclarationRef
x) forall a. Semigroup a => a -> a -> a
<> Text
" requires the following to also be exported: "
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationRef -> Text
prettyPrintExport) [DeclarationRef]
ys
            ]
    renderSimpleErrorMessage (TransitiveDctorExportError DeclarationRef
x [ProperName 'ConstructorName]
ctors) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"An export for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (DeclarationRef -> Text
prettyPrintExport DeclarationRef
x) forall a. Semigroup a => a -> a -> a
<> Text
" requires the following data constructor" forall a. Semigroup a => a -> a -> a
<> (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProperName 'ConstructorName]
ctors forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"" else Text
"s") forall a. Semigroup a => a -> a -> a
<> Text
" to also be exported: "
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
runProperName) [ProperName 'ConstructorName]
ctors
            ]
    renderSimpleErrorMessage (HiddenConstructors DeclarationRef
x Qualified (ProperName 'ClassName)
className) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"An export for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (DeclarationRef -> Text
prettyPrintExport DeclarationRef
x) forall a. Semigroup a => a -> a -> a
<> Text
" hides data constructors but the type declares an instance of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
className) forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text -> Box
line Text
"Such instance allows to match and construct values of this type, effectively making the constructors public."
            ]
    renderSimpleErrorMessage (ShadowedName Ident
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Name " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
nm) forall a. Semigroup a => a -> a -> a
<> Text
" was shadowed."
    renderSimpleErrorMessage (ShadowedTypeVar Text
tv) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
tv forall a. Semigroup a => a -> a -> a
<> Text
" was shadowed."
    renderSimpleErrorMessage (UnusedName Ident
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Name " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
nm) forall a. Semigroup a => a -> a -> a
<> Text
" was introduced but not used."
    renderSimpleErrorMessage (UnusedDeclaration Ident
nm) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Declaration " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
nm) forall a. Semigroup a => a -> a -> a
<> Text
" was not used, and is not exported."
    renderSimpleErrorMessage (UnusedTypeVar Text
tv) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
tv forall a. Semigroup a => a -> a -> a
<> Text
" is ambiguous, since it is unused in the polymorphic type which introduces it."
    renderSimpleErrorMessage (ImportHidingModule ModuleName
name) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"hiding imports cannot be used to hide modules."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"An attempt was made to hide the import of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
name)
            ]
    renderSimpleErrorMessage (WildcardInferredType Type SourceAnn
ty Context
ctx) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ [ Text -> Box
line Text
"Wildcard type definition has the inferred type "
              , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
              ] forall a. Semigroup a => a -> a -> a
<> Context -> [Box]
renderContext Context
ctx
    renderSimpleErrorMessage (HoleInferredType Text
name Type SourceAnn
ty Context
ctx Maybe TypeSearch
ts) =
      let
        maxTSResults :: Int
maxTSResults = Int
15
        tsResult :: [Box]
tsResult = case Maybe TypeSearch
ts of
          Just TSAfter{tsAfterIdentifiers :: TypeSearch -> [(Qualified Text, Type SourceAnn)]
tsAfterIdentifiers=[(Qualified Text, Type SourceAnn)]
idents} | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Qualified Text, Type SourceAnn)]
idents) ->
            let
              formatTS :: ([Qualified Text], [Type a]) -> Box
formatTS ([Qualified Text]
names, [Type a]
types) =
                let
                  idBoxes :: [Box]
idBoxes = FilePath -> Box
Box.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
showQualified forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Qualified Text]
names
                  tyBoxes :: [Box]
tyBoxes = (\Type a
t -> Box -> Box
BoxHelpers.indented
                              (FilePath -> Box
Box.text FilePath
":: " Box -> Box -> Box
Box.<> forall a. Type a -> Box
prettyType Type a
t)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type a]
types
                  longestId :: Int
longestId = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map Box -> Int
Box.cols [Box]
idBoxes)
                in
                  forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.top forall a b. (a -> b) -> a -> b
$
                      forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Box -> Box -> Box
(Box.<>)
                      (Alignment -> Int -> Box -> Box
Box.alignHoriz Alignment
Box.left Int
longestId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Box]
idBoxes)
                      [Box]
tyBoxes
            in [ Text -> Box
line Text
"You could substitute the hole with one of these values:"
               , Box -> Box
markCodeBox (Box -> Box
indent (forall {a}. ([Qualified Text], [Type a]) -> Box
formatTS (forall a b. [(a, b)] -> ([a], [b])
unzip (forall a. Int -> [a] -> [a]
take Int
maxTSResults [(Qualified Text, Type SourceAnn)]
idents))))
               ]
          Maybe TypeSearch
_ -> []
      in
        forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Hole '" forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
name forall a. Semigroup a => a -> a -> a
<> Text
"' has the inferred type "
                , Box -> Box
markCodeBox (Box -> Box
indent (forall a. Int -> Type a -> Box
prettyTypeWithDepth forall a. Bounded a => a
maxBound Type SourceAnn
ty))
                ] forall a. [a] -> [a] -> [a]
++ [Box]
tsResult forall a. [a] -> [a] -> [a]
++ Context -> [Box]
renderContext Context
ctx
    renderSimpleErrorMessage (MissingTypeDeclaration Ident
ident Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"No type declaration was provided for the top-level declaration of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident) forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text -> Box
line Text
"It is good practice to provide type declarations as a form of documentation."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The inferred type of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident) forall a. Semigroup a => a -> a -> a
<> Text
" was:"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
prettyTypeWithDepth forall a. Bounded a => a
maxBound Type SourceAnn
ty
            ]
    renderSimpleErrorMessage (MissingKindDeclaration KindSignatureFor
sig ProperName 'TypeName
name Type SourceAnn
ty) =
      let sigKw :: Text
sigKw = KindSignatureFor -> Text
prettyPrintKindSignatureFor KindSignatureFor
sig in
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The inferred kind for the " forall a. Semigroup a => a -> a -> a
<> Text
sigKw forall a. Semigroup a => a -> a -> a
<> Text
" declaration " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name) forall a. Semigroup a => a -> a -> a
<> Text
" contains polymorphic kinds."
            , Text -> Box
line Text
"Consider adding a top-level kind signature as a form of documentation."
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
sigKw forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name forall a. Semigroup a => a -> a -> a
<> Text
" ::"
                , forall a. Int -> Type a -> Box
prettyTypeWithDepth forall a. Bounded a => a
maxBound Type SourceAnn
ty
                ]
            ]
    renderSimpleErrorMessage (OverlappingPattern [[Binder]]
bs Bool
b) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ [ Text -> Box
line Text
"A case expression contains unreachable cases:\n"
              , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *). Foldable f => f Box -> Box
paras forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder -> Text
prettyPrintBinderAtom)) (forall a. [[a]] -> [[a]]
transpose [[Binder]]
bs))
              ] forall a. [a] -> [a] -> [a]
++
              [ Text -> Box
line Text
"..." | Bool -> Bool
not Bool
b ]
    renderSimpleErrorMessage SimpleErrorMessage
IncompleteExhaustivityCheck =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"An exhaustivity check was abandoned due to too many possible cases."
            , Text -> Box
line Text
"You may want to decompose your data types into smaller types."
            ]

    renderSimpleErrorMessage (UnusedImport ModuleName
mn Maybe ModuleName
qualifier) =
      let
        mark :: ModuleName -> Text
mark = Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
runModuleName
        unqualified :: Text
unqualified = Text
"The import of " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
mark ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
" is redundant"
        msg' :: ModuleName -> Text
msg' ModuleName
q = Text
"The qualified import of " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
mark ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
" as " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
mark ModuleName
q forall a. Semigroup a => a -> a -> a
<> Text
" is redundant"
        msg :: Maybe ModuleName -> Text
msg = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
unqualified ModuleName -> Text
msg'
      in Text -> Box
line forall a b. (a -> b) -> a -> b
$ Maybe ModuleName -> Text
msg Maybe ModuleName
qualifier

    renderSimpleErrorMessage msg :: SimpleErrorMessage
msg@(UnusedExplicitImport ModuleName
mn [Name]
names Maybe ModuleName
_ [DeclarationRef]
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The import of module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" contains the following unused references:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified Name -> Text
runName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos) [Name]
names
            , Text -> Box
line Text
"It could be replaced with:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
msg ]

    renderSimpleErrorMessage msg :: SimpleErrorMessage
msg@(UnusedDctorImport ModuleName
mn ProperName 'TypeName
name Maybe ModuleName
_ [DeclarationRef]
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The import of type " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name)
                    forall a. Semigroup a => a -> a -> a
<> Text
" from module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" includes data constructors but only the type is used"
            , Text -> Box
line Text
"It could be replaced with:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
msg ]

    renderSimpleErrorMessage msg :: SimpleErrorMessage
msg@(UnusedDctorExplicitImport ModuleName
mn ProperName 'TypeName
name [ProperName 'ConstructorName]
names Maybe ModuleName
_ [DeclarationRef]
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The import of type " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name)
                     forall a. Semigroup a => a -> a -> a
<> Text
" from module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" includes the following unused data constructors:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
runProperName) [ProperName 'ConstructorName]
names
            , Text -> Box
line Text
"It could be replaced with:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
msg ]

    renderSimpleErrorMessage (DuplicateSelectiveImport ModuleName
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"There is an existing import of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
name) forall a. Semigroup a => a -> a -> a
<> Text
", consider merging the import lists"

    renderSimpleErrorMessage (DuplicateImport ModuleName
name ImportDeclarationType
imp Maybe ModuleName
qual) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Duplicate import of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text
prettyPrintImport ModuleName
name ImportDeclarationType
imp Maybe ModuleName
qual)

    renderSimpleErrorMessage (DuplicateImportRef Name
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Import list contains multiple references to " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Name
name)

    renderSimpleErrorMessage (DuplicateExportRef Name
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Export list contains multiple references to " forall a. Semigroup a => a -> a -> a
<> Qualified Name -> Text
printName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Name
name)

    renderSimpleErrorMessage (IntOutOfRange Integer
value Text
backend Integer
lo Integer
hi) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Integer value " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Integer
value)) forall a. Semigroup a => a -> a -> a
<> Text
" is out of range for the " forall a. Semigroup a => a -> a -> a
<> Text
backend forall a. Semigroup a => a -> a -> a
<> Text
" backend."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Acceptable values fall within the range " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Integer
lo)) forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Integer
hi)) forall a. Semigroup a => a -> a -> a
<> Text
" (inclusive)." ]

    renderSimpleErrorMessage msg :: SimpleErrorMessage
msg@(ImplicitQualifiedImport ModuleName
importedModule ModuleName
asModule [DeclarationRef]
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
importedModule) forall a. Semigroup a => a -> a -> a
<> Text
" was imported as " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
asModule) forall a. Semigroup a => a -> a -> a
<> Text
" with unspecified imports."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"As there are multiple modules being imported as " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
asModule) forall a. Semigroup a => a -> a -> a
<> Text
", consider using the explicit form:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
msg
            ]
    renderSimpleErrorMessage msg :: SimpleErrorMessage
msg@(ImplicitQualifiedImportReExport ModuleName
importedModule ModuleName
asModule [DeclarationRef]
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
importedModule) forall a. Semigroup a => a -> a -> a
<> Text
" was imported as " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
asModule) forall a. Semigroup a => a -> a -> a
<> Text
" with unspecified imports."
            , Text -> Box
line Text
"As this module is being re-exported, consider using the explicit form:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
msg
            ]

    renderSimpleErrorMessage msg :: SimpleErrorMessage
msg@(ImplicitImport ModuleName
mn [DeclarationRef]
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" has unspecified imports, consider using the explicit form: "
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
msg
            ]

    renderSimpleErrorMessage msg :: SimpleErrorMessage
msg@(HidingImport ModuleName
mn [DeclarationRef]
_) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" has unspecified imports, consider using the inclusive form: "
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage -> Text
showSuggestion SimpleErrorMessage
msg
            ]

    renderSimpleErrorMessage (CaseBinderLengthDiffers Int
l [Binder]
bs) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"Binder list length differs in case alternative:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Binder -> Text
prettyPrintBinderAtom [Binder]
bs
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Expecting " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
l) forall a. Semigroup a => a -> a -> a
<> Text
" binder" forall a. Semigroup a => a -> a -> a
<> (if Int
l forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"" else Text
"s") forall a. Semigroup a => a -> a -> a
<> Text
"."
            ]

    renderSimpleErrorMessage SimpleErrorMessage
IncorrectAnonymousArgument =
      Text -> Box
line Text
"An anonymous function argument appears in an invalid context."

    renderSimpleErrorMessage (InvalidOperatorInBinder Qualified (OpName 'ValueOpName)
op Qualified Ident
fn) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Operator " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: OpNameType). OpName a -> Text
showOp Qualified (OpName 'ValueOpName)
op) forall a. Semigroup a => a -> a -> a
<> Text
" cannot be used in a pattern as it is an alias for function " forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
showIdent Qualified Ident
fn forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text -> Box
line Text
"Only aliases for data constructors may be used in patterns."
            ]

    renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction Ident
ident Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Unable to generalize the type of the recursive function " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident) forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The inferred type of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident) forall a. Semigroup a => a -> a -> a
<> Text
" was:"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
            , Text -> Box
line Text
"Try adding a type signature."
            ]

    renderSimpleErrorMessage (CannotDeriveNewtypeForData ProperName 'TypeName
tyName) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Cannot derive an instance of the " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
"Newtype" forall a. Semigroup a => a -> a -> a
<> Text
" class for non-newtype " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
tyName) forall a. Semigroup a => a -> a -> a
<> Text
"."
            ]

    renderSimpleErrorMessage (ExpectedWildcard ProperName 'TypeName
tyName) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Expected a type wildcard (_) when deriving an instance for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
tyName) forall a. Semigroup a => a -> a -> a
<> Text
"."
            ]

    renderSimpleErrorMessage (CannotUseBindWithDo Ident
name) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The name " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
name) forall a. Semigroup a => a -> a -> a
<> Text
" cannot be brought into scope in a do notation block, since do notation uses the same name."
            ]

    renderSimpleErrorMessage (ClassInstanceArityMismatch Ident
dictName Qualified (ProperName 'ClassName)
className Int
expected Int
actual) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The type class " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
className) forall a. Semigroup a => a -> a -> a
<>
                     Text
" expects " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
expected) forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
argsMsg forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"But the instance" forall a. Semigroup a => a -> a -> a
<> Ident -> Text
prettyPrintPlainIdent Ident
dictName forall a. Semigroup a => a -> a -> a
<> Text
mismatchMsg forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
actual) forall a. Semigroup a => a -> a -> a
<> Text
"."
            ]
        where
          mismatchMsg :: Text
mismatchMsg = if Int
actual forall a. Ord a => a -> a -> Bool
> Int
expected then Text
" provided " else Text
" only provided "
          argsMsg :: Text
argsMsg = if Int
expected forall a. Ord a => a -> a -> Bool
> Int
1 then Text
"arguments" else Text
"argument"

    renderSimpleErrorMessage (UserDefinedWarning Type SourceAnn
msgTy) =
      let msg :: Box
msg = forall a. a -> Maybe a -> a
fromMaybe (forall a. Type a -> Box
prettyType Type SourceAnn
msgTy) (forall a. Type a -> Maybe Box
toTypelevelString Type SourceAnn
msgTy) in
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line Text
"A custom warning occurred while solving type class constraints:"
            , Box -> Box
indent Box
msg
            ]

    renderSimpleErrorMessage (CannotDefinePrimModules ModuleName
mn) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"The module name " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> Text
" is in the Prim namespace."
        , Text -> Box
line Text
"The Prim namespace is reserved for compiler-defined terms."
        ]

    renderSimpleErrorMessage (MixedAssociativityError NonEmpty (Qualified (OpName 'AnyOpName), Associativity)
opsWithAssoc) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line Text
"Cannot parse an expression that uses operators of the same precedence but mixed associativity:"
        , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Qualified (OpName 'AnyOpName)
name, Associativity
assoc) -> Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: OpNameType). OpName a -> Text
showOp Qualified (OpName 'AnyOpName)
name) forall a. Semigroup a => a -> a -> a
<> Text
" is " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (FilePath -> Text
T.pack (Associativity -> FilePath
showAssoc Associativity
assoc))) (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Qualified (OpName 'AnyOpName), Associativity)
opsWithAssoc)
        , Text -> Box
line Text
"Use parentheses to resolve this ambiguity."
        ]

    renderSimpleErrorMessage (NonAssociativeError NonEmpty (Qualified (OpName 'AnyOpName))
ops) =
      if forall a. NonEmpty a -> Int
NEL.length NonEmpty (Qualified (OpName 'AnyOpName))
ops forall a. Eq a => a -> a -> Bool
== Int
1
        then
          forall (f :: * -> *). Foldable f => f Box -> Box
paras
            [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Cannot parse an expression that uses multiple instances of the non-associative operator " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: OpNameType). OpName a -> Text
showOp (forall a. NonEmpty a -> a
NEL.head NonEmpty (Qualified (OpName 'AnyOpName))
ops)) forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text -> Box
line Text
"Use parentheses to resolve this ambiguity."
            ]
        else
          forall (f :: * -> *). Foldable f => f Box -> Box
paras
            [ Text -> Box
line Text
"Cannot parse an expression that uses multiple non-associative operators of the same precedence:"
            , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: OpNameType). OpName a -> Text
showOp) (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Qualified (OpName 'AnyOpName))
ops)
            , Text -> Box
line Text
"Use parentheses to resolve this ambiguity."
            ]

    renderSimpleErrorMessage (QuantificationCheckFailureInKind Text
var) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Cannot generalize the kind of type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
var forall a. Semigroup a => a -> a -> a
<> Text
" since it would not be well-scoped."
        , Text -> Box
line Text
"Try adding a kind annotation."
        ]

    renderSimpleErrorMessage (QuantificationCheckFailureInType [Int]
us Type SourceAnn
ty) =
      let unks :: [Box]
unks =
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
u -> forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Box
"where"
                                           , Box -> Box
markCodeBox (forall a. Type a -> Box
prettyType (Int -> Type SourceAnn
srcTUnknown Int
u))
                                           , Box
"is an unknown kind."
                                           ]) [Int]
us
      in forall (f :: * -> *). Foldable f => f Box -> Box
paras
           [ Text -> Box
line Text
"Cannot unambiguously generalize kinds appearing in the elaborated type:"
           , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
ty
           , forall (f :: * -> *). Foldable f => f Box -> Box
paras [Box]
unks
           , Text -> Box
line Text
"Try adding additional kind signatures or polymorphic kind variables."
           ]

    renderSimpleErrorMessage (VisibleQuantificationCheckFailureInType Text
var) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Visible dependent quantification of type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
var forall a. Semigroup a => a -> a -> a
<> Text
" is not supported."
        , Text -> Box
line Text
"If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre)."
        ]

    renderSimpleErrorMessage (UnsupportedTypeInKind Type SourceAnn
ty) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line Text
"The type:"
        , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
ty
        , Text -> Box
line Text
"is not supported in kinds."
        ]

    renderSimpleErrorMessage (RoleMismatch Text
var Role
inferred Role
declared) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Role mismatch for the type parameter " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
var forall a. Semigroup a => a -> a -> a
<> Text
":"
        , Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Box
line forall a b. (a -> b) -> a -> b
$
            Text
"The annotation says " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Role -> Text
displayRole Role
declared) forall a. Semigroup a => a -> a -> a
<>
            Text
" but the role " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Role -> Text
displayRole Role
inferred) forall a. Semigroup a => a -> a -> a
<>
            Text
" is required."
        ]

    renderSimpleErrorMessage (InvalidCoercibleInstanceDeclaration [Type SourceAnn]
tys) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line Text
"Invalid type class instance declaration for"
        , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
            [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
C.Coercible)
            , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Type a -> Box
prettyTypeAtom [Type SourceAnn]
tys)
            ]
        , Text -> Box
line Text
"Instance declarations of this type class are disallowed."
        ]

    renderSimpleErrorMessage SimpleErrorMessage
UnsupportedRoleDeclaration =
      Text -> Box
line Text
"Role declarations are only supported for data types, not for type synonyms nor type classes."

    renderSimpleErrorMessage (RoleDeclarationArityMismatch ProperName 'TypeName
name Int
expected Int
actual) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
" "
        [ Text
"The type"
        , Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name)
        , Text
"expects"
        , FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
expected)
        , if Int
expected forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"argument" else Text
"arguments"
        , Text
"but its role declaration lists"
            forall a. Semigroup a => a -> a -> a
<> if Int
actual forall a. Ord a => a -> a -> Bool
> Int
expected then Text
"" else Text
" only"
        , FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
actual)
        , if Int
actual forall a. Ord a => a -> a -> Bool
> Int
1 then Text
"roles" else Text
"role"
        ] forall a. Semigroup a => a -> a -> a
<> Text
"."

    renderSimpleErrorMessage (DuplicateRoleDeclaration ProperName 'TypeName
name) =
      Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Duplicate role declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name) forall a. Semigroup a => a -> a -> a
<> Text
"."

    renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg Qualified (ProperName 'ClassName)
className [Qualified (ProperName 'ClassName)]
relatedClasses Bool
checkVariance) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"One or more type variables are in positions that prevent " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName forall a b. (a -> b) -> a -> b
$ forall a. Qualified a -> a
disqualify Qualified (ProperName 'ClassName)
className) forall a. Semigroup a => a -> a -> a
<> Text
" from being derived."
        , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"To derive this class, make sure that these variables are only used as the final arguments to type constructors, "
          forall a. Semigroup a => a -> a -> a
<> (if Bool
checkVariance then Text
"that their variance matches the variance of " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName forall a b. (a -> b) -> a -> b
$ forall a. Qualified a -> a
disqualify Qualified (ProperName 'ClassName)
className) forall a. Semigroup a => a -> a -> a
<> Text
", " else Text
"")
          forall a. Semigroup a => a -> a -> a
<> Text
"and that those type constructors themselves have instances of " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
commasAndConjunction Text
"or" (Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Qualified (ProperName 'ClassName)]
relatedClasses) forall a. Semigroup a => a -> a -> a
<> Text
"."
        ]

    renderSimpleErrorMessage (CannotSkipTypeApplication Type SourceAnn
tyFn) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Box
"An expression of type:"
        , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
tyFn
        , Box
"cannot be skipped."
        ]

    renderSimpleErrorMessage (CannotApplyExpressionOfTypeOnType Type SourceAnn
tyFn Type SourceAnn
tyAr) =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras forall a b. (a -> b) -> a -> b
$ [Box]
infoLine forall a. Semigroup a => a -> a -> a
<>
        [ Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
tyFn
        , Box
"cannot be applied to:"
        , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Box
prettyType Type SourceAnn
tyAr
        ]
      where
      infoLine :: [Box]
infoLine =
        if forall a. Type a -> Bool
isMonoType Type SourceAnn
tyFn then
          [ Box
"An expression of monomorphic type:" ]
        else
          [ Box
"An expression of polymorphic type"
          , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"with the invisible type variable " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode Text
typeVariable forall a. Semigroup a => a -> a -> a
<> Text
":"
          ]

      typeVariable :: Text
typeVariable = case Type SourceAnn
tyFn of
        ForAll SourceAnn
_ TypeVarVisibility
_ Text
v Maybe (Type SourceAnn)
_ Type SourceAnn
_ Maybe SkolemScope
_ -> Text
v
        Type SourceAnn
_ -> forall a. HasCallStack => FilePath -> a
internalError FilePath
"renderSimpleErrorMessage: Impossible!"

    renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
    renderHint :: ErrorMessageHint -> Box -> Box
renderHint (ErrorUnifyingTypes t1 :: Type SourceAnn
t1@RCons{} t2 :: Type SourceAnn
t2@RCons{}) Box
detail =
      let (Box
row1Box, Box
row2Box) = forall a. Type a -> Type a -> (Box, Box)
printRows Type SourceAnn
t1 Type SourceAnn
t2
      in forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while trying to match type"
                                 , Box
row1Box
                                 ]
            , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"with type"
                                                   , Box
row2Box
                                                   ]
            ]
    renderHint (ErrorUnifyingTypes Type SourceAnn
t1 Type SourceAnn
t2) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while trying to match type"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
t1
                                 ]
            , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"with type"
                                                   , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
t2
                                                   ]
            ]
    renderHint (ErrorInExpression Expr
expr) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ FilePath -> Box
Box.text FilePath
"in the expression"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth Expr
expr
                                 ]
            ]
    renderHint (ErrorInModule ModuleName
mn) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in module " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (ModuleName -> Text
runModuleName ModuleName
mn)
            , Box
detail
            ]
    renderHint (ErrorInSubsumption Type SourceAnn
t1 Type SourceAnn
t2) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while checking that type"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
t1
                                 ]
            , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"is at least as general as type"
                                                   , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
t2
                                                   ]
            ]
    renderHint (ErrorInRowLabel Label
lb) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while matching label"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ PSString -> Text
prettyPrintObjectKey (Label -> PSString
runLabel Label
lb)
                                 ]
            ]
    renderHint (ErrorInInstance Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
ts) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line Text
"in type class instance"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top
               [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm
               , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> Type a -> Box
typeAtomAsBox Int
prettyDepth) [Type SourceAnn]
ts)
               ]
            ]
    renderHint (ErrorCheckingKind Type SourceAnn
ty Type SourceAnn
kd) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while checking that type"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
ty
                                 ]
            , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"has kind"
                                                   , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
kd
                                                   ]
            ]
    renderHint (ErrorInferringKind Type SourceAnn
ty) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while inferring the kind of"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
ty
                                 ]
            ]
    renderHint ErrorMessageHint
ErrorCheckingGuard Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line Text
"while checking the type of a guard clause"
            ]
    renderHint (ErrorInferringType Expr
expr) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while inferring the type of"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth Expr
expr
                                 ]
            ]
    renderHint (ErrorCheckingType Expr
expr Type SourceAnn
ty) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while checking that expression"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth Expr
expr
                                 ]
            , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"has type"
                                                   , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
ty
                                                   ]
            ]
    renderHint (ErrorCheckingAccessor Expr
expr PSString
prop) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while checking type of property accessor"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth (PSString -> Expr -> Expr
Accessor PSString
prop Expr
expr)
                                 ]
            ]
    renderHint (ErrorInApplication Expr
f Type SourceAnn
t Expr
a) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"while applying a function"
                                 , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth Expr
f
                                 ]
            , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"of type"
                                                   , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
t
                                                   ]
            , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.top [ Text -> Box
line Text
"to argument"
                                                   , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Int -> Expr -> Box
prettyPrintValue Int
prettyDepth Expr
a
                                                   ]
            ]
    renderHint (ErrorInDataConstructor ProperName 'ConstructorName
nm) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in data constructor " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'ConstructorName
nm)
            ]
    renderHint (ErrorInTypeConstructor ProperName 'TypeName
nm) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in type constructor " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
nm)
            ]
    renderHint (ErrorInBindingGroup NonEmpty Ident
nms) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in binding group " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a. NonEmpty a -> [a]
NEL.toList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> Text
showIdent NonEmpty Ident
nms))
            ]
    renderHint (ErrorInDataBindingGroup [ProperName 'TypeName]
nms) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in data binding group " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall (a :: ProperNameType). ProperName a -> Text
runProperName [ProperName 'TypeName]
nms)
            ]
    renderHint (ErrorInTypeSynonym ProperName 'TypeName
name) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in type synonym " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name)
            ]
    renderHint (ErrorInValueDeclaration Ident
n) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in value declaration " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
n)
            ]
    renderHint (ErrorInTypeDeclaration Ident
n) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in type declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
n)
            ]
    renderHint (ErrorInTypeClassDeclaration ProperName 'ClassName
name) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in type class declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'ClassName
name)
            ]
    renderHint (ErrorInKindDeclaration ProperName 'TypeName
name) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in kind declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name)
            ]
    renderHint (ErrorInRoleDeclaration ProperName 'TypeName
name) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in role declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
name)
            ]
    renderHint (ErrorInForeignImport Ident
nm) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in foreign import " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
nm)
            ]
    renderHint (ErrorInForeignImportData ProperName 'TypeName
nm) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"in foreign data type declaration for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
nm)
            ]
    renderHint (ErrorSolvingConstraint (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
nm [Type SourceAnn]
_ [Type SourceAnn]
ts Maybe ConstraintData
_)) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Box
detail
            , Text -> Box
line Text
"while solving type class constraint"
            , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.hsep Int
1 Alignment
Box.left
                [ Text -> Box
line (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ClassName)
nm)
                , forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> Type a -> Box
typeAtomAsBox Int
prettyDepth) [Type SourceAnn]
ts)
                ]
            ]
    renderHint (MissingConstructorImportForCoercible Qualified (ProperName 'ConstructorName)
name) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Box
detail
        , Int -> Box -> Box
Box.moveUp Int
1 forall a b. (a -> b) -> a -> b
$ Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"Solving this instance requires the newtype constructor " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName 'ConstructorName)
name) forall a. Semigroup a => a -> a -> a
<> Text
" to be in scope."
        ]
    renderHint (PositionedError NonEmpty SourceSpan
srcSpan) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras [ Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"at " forall a. Semigroup a => a -> a -> a
<> FilePath -> SourceSpan -> Text
displaySourceSpan FilePath
relPath (forall a. NonEmpty a -> a
NEL.head NonEmpty SourceSpan
srcSpan)
            , Box
detail
            ]
    renderHint (RelatedPositions NonEmpty SourceSpan
srcSpans) Box
detail =
      forall (f :: * -> *). Foldable f => f Box -> Box
paras
        [ Box
detail
        , Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$ NonEmpty SourceSpan -> Box
showSourceSpansInContext NonEmpty SourceSpan
srcSpans
        ]

    printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box
    printRow :: forall a. (Int -> Type a -> Box) -> Type a -> Box
printRow Int -> Type a -> Box
f = Box -> Box
markCodeBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> Box
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type a -> Box
f Int
prettyDepth forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      if Bool
full then forall a. a -> a
id else forall a. Type a -> Type a
eraseForAllKindAnnotations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
eraseKindApps

    -- If both rows are not empty, print them as diffs
    -- If verbose print all rows else only print unique rows
    printRows :: Type a -> Type a -> (Box.Box, Box.Box)
    printRows :: forall a. Type a -> Type a -> (Box, Box)
printRows Type a
r1 Type a
r2 = case (Bool
full, Type a
r1, Type a
r2) of
      (Bool
True, Type a
_ , Type a
_) -> (forall a. (Int -> Type a -> Box) -> Type a -> Box
printRow forall a. Int -> Type a -> Box
typeAsBox Type a
r1, forall a. (Int -> Type a -> Box) -> Type a -> Box
printRow forall a. Int -> Type a -> Box
typeAsBox Type a
r2)

      (Bool
_, RCons{}, RCons{}) ->
        let (Type a
sorted1, Type a
sorted2) = forall a.
([RowListItem a], Type a)
-> ([RowListItem a], Type a) -> (Type a, Type a)
filterRows (forall a. Type a -> ([RowListItem a], Type a)
rowToList Type a
r1) (forall a. Type a -> ([RowListItem a], Type a)
rowToList Type a
r2)
        in (forall a. (Int -> Type a -> Box) -> Type a -> Box
printRow forall a. Int -> Type a -> Box
typeDiffAsBox Type a
sorted1, forall a. (Int -> Type a -> Box) -> Type a -> Box
printRow forall a. Int -> Type a -> Box
typeDiffAsBox Type a
sorted2)

      (Bool
_, Type a
_, Type a
_) -> (forall a. (Int -> Type a -> Box) -> Type a -> Box
printRow forall a. Int -> Type a -> Box
typeAsBox Type a
r1, forall a. (Int -> Type a -> Box) -> Type a -> Box
printRow forall a. Int -> Type a -> Box
typeAsBox Type a
r2)


    -- Keep the unique labels only
    filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a)
    filterRows :: forall a.
([RowListItem a], Type a)
-> ([RowListItem a], Type a) -> (Type a, Type a)
filterRows ([RowListItem a]
s1, Type a
r1) ([RowListItem a]
s2, Type a
r2) =
         let sort' :: [RowListItem a] -> [RowListItem a]
sort' = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a -> b) -> a -> b
$ \(RowListItem a
_ Label
name Type a
ty) -> (Label
name, Type a
ty)
             ([RowListItem a]
unique1, [RowListItem a]
unique2) = forall a.
([RowListItem a], [RowListItem a])
-> ([RowListItem a], [RowListItem a])
diffSortedRowLists (forall {a}. [RowListItem a] -> [RowListItem a]
sort' [RowListItem a]
s1, forall {a}. [RowListItem a] -> [RowListItem a]
sort' [RowListItem a]
s2)
          in ( forall a. ([RowListItem a], Type a) -> Type a
rowFromList ([RowListItem a]
unique1, Type a
r1)
             , forall a. ([RowListItem a], Type a) -> Type a
rowFromList ([RowListItem a]
unique2, Type a
r2)
             )

    -- Importantly, this removes exactly the same number of elements from
    -- both lists, even if there are repeated (name, ty) keys. It requires
    -- the inputs to be sorted but ensures that the outputs remain sorted.
    diffSortedRowLists :: ([RowListItem a], [RowListItem a]) -> ([RowListItem a], [RowListItem a])
    diffSortedRowLists :: forall a.
([RowListItem a], [RowListItem a])
-> ([RowListItem a], [RowListItem a])
diffSortedRowLists = forall a.
([RowListItem a], [RowListItem a])
-> ([RowListItem a], [RowListItem a])
go where
      go :: ([RowListItem a], [RowListItem a])
-> ([RowListItem a], [RowListItem a])
go = \case
        (s1 :: [RowListItem a]
s1@(h1 :: RowListItem a
h1@(RowListItem a
_ Label
name1 Type a
ty1) : [RowListItem a]
t1), s2 :: [RowListItem a]
s2@(h2 :: RowListItem a
h2@(RowListItem a
_ Label
name2 Type a
ty2) : [RowListItem a]
t2)) ->
          case (Label
name1, Type a
ty1) forall a. Ord a => a -> a -> Ordering
`compare` (Label
name2, Type a
ty2) of
            Ordering
EQ ->                ([RowListItem a], [RowListItem a])
-> ([RowListItem a], [RowListItem a])
go ([RowListItem a]
t1, [RowListItem a]
t2)
            Ordering
LT -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first  (RowListItem a
h1forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ ([RowListItem a], [RowListItem a])
-> ([RowListItem a], [RowListItem a])
go ([RowListItem a]
t1, [RowListItem a]
s2)
            Ordering
GT -> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (RowListItem a
h2forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ ([RowListItem a], [RowListItem a])
-> ([RowListItem a], [RowListItem a])
go ([RowListItem a]
s1, [RowListItem a]
t2)
        ([RowListItem a], [RowListItem a])
other -> ([RowListItem a], [RowListItem a])
other

    renderContext :: Context -> [Box.Box]
    renderContext :: Context -> [Box]
renderContext [] = []
    renderContext Context
ctx =
      [ Text -> Box
line Text
"in the following context:"
      , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => f Box -> Box
paras
          [ forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.hcat Alignment
Box.left [ FilePath -> Box
Box.text (Text -> FilePath
T.unpack (Ident -> Text
showIdent Ident
ident) forall a. [a] -> [a] -> [a]
++ FilePath
" :: ")
                              , Box -> Box
markCodeBox forall a b. (a -> b) -> a -> b
$ forall a. Int -> Type a -> Box
typeAsBox Int
prettyDepth Type SourceAnn
ty'
                              ]
          | (Ident
ident, Type SourceAnn
ty') <- forall a. Int -> [a] -> [a]
take Int
30 Context
ctx
          ]
      ]

    printName :: Qualified Name -> Text
    printName :: Qualified Name -> Text
printName Qualified Name
qn = Name -> Text
nameType (forall a. Qualified a -> a
disqualify Qualified Name
qn) forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Qualified Name -> Text
runName Qualified Name
qn)

    nameType :: Name -> Text
    nameType :: Name -> Text
nameType (IdentName Ident
_) = Text
"value"
    nameType (ValOpName OpName 'ValueOpName
_) = Text
"operator"
    nameType (TyName ProperName 'TypeName
_) = Text
"type"
    nameType (TyOpName OpName 'TypeOpName
_) = Text
"type operator"
    nameType (DctorName ProperName 'ConstructorName
_) = Text
"data constructor"
    nameType (TyClassName ProperName 'ClassName
_) = Text
"type class"
    nameType (ModName ModuleName
_) = Text
"module"

    runName :: Qualified Name -> Text
    runName :: Qualified Name -> Text
runName (Qualified QualifiedBy
qb (IdentName Ident
name)) =
      forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
showIdent (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb Ident
name)
    runName (Qualified QualifiedBy
qb (ValOpName OpName 'ValueOpName
op)) =
      forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: OpNameType). OpName a -> Text
showOp (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb OpName 'ValueOpName
op)
    runName (Qualified QualifiedBy
qb (TyName ProperName 'TypeName
name)) =
      forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb ProperName 'TypeName
name)
    runName (Qualified QualifiedBy
qb (TyOpName OpName 'TypeOpName
op)) =
      forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: OpNameType). OpName a -> Text
showOp (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb OpName 'TypeOpName
op)
    runName (Qualified QualifiedBy
qb (DctorName ProperName 'ConstructorName
name)) =
      forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb ProperName 'ConstructorName
name)
    runName (Qualified QualifiedBy
qb (TyClassName ProperName 'ClassName
name)) =
      forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb ProperName 'ClassName
name)
    runName (Qualified (BySourcePos SourcePos
_) (ModName ModuleName
name)) =
      ModuleName -> Text
runModuleName ModuleName
name
    runName (Qualified QualifiedBy
_ ModName{}) =
      forall a. HasCallStack => FilePath -> a
internalError FilePath
"qualified ModName in runName"

  prettyDepth :: Int
  prettyDepth :: Int
prettyDepth | Bool
full = Int
1000
              | Bool
otherwise = Int
3

  prettyType :: Type a -> Box.Box
  prettyType :: forall a. Type a -> Box
prettyType = forall a. Int -> Type a -> Box
prettyTypeWithDepth Int
prettyDepth

  prettyTypeWithDepth :: Int -> Type a -> Box.Box
  prettyTypeWithDepth :: forall a. Int -> Type a -> Box
prettyTypeWithDepth Int
depth
    | Bool
full = forall a. Int -> Type a -> Box
typeAsBox Int
depth
    | Bool
otherwise = forall a. Int -> Type a -> Box
typeAsBox Int
depth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
eraseForAllKindAnnotations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
eraseKindApps

  prettyTypeAtom :: Type a -> Box.Box
  prettyTypeAtom :: forall a. Type a -> Box
prettyTypeAtom
    | Bool
full = forall a. Int -> Type a -> Box
typeAtomAsBox Int
prettyDepth
    | Bool
otherwise = forall a. Int -> Type a -> Box
typeAtomAsBox Int
prettyDepth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
eraseForAllKindAnnotations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
eraseKindApps

  levelText :: Text
  levelText :: Text
levelText = case Level
level of
    Level
Error -> Text
"error"
    Level
Warning -> Text
"warning"

  paras :: forall f. Foldable f => f Box.Box -> Box.Box
  paras :: forall (f :: * -> *). Foldable f => f Box -> Box
paras = forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left

  -- Simplify an error message
  simplifyErrorMessage :: ErrorMessage -> ErrorMessage
  simplifyErrorMessage :: ErrorMessage -> ErrorMessage
simplifyErrorMessage (ErrorMessage [ErrorMessageHint]
hints SimpleErrorMessage
simple) = [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage ([ErrorMessageHint] -> [ErrorMessageHint]
simplifyHints [ErrorMessageHint]
hints) SimpleErrorMessage
simple
    where
    -- Take the last instance of each "hint category"
    simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
    simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
simplifyHints = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ErrorMessageHint -> ErrorMessageHint -> Bool
categoriesEqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
stripRedundantHints SimpleErrorMessage
simple forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

    -- Don't remove hints in the "other" category
    categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
    categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
categoriesEqual ErrorMessageHint
x ErrorMessageHint
y =
      case (ErrorMessageHint -> HintCategory
hintCategory ErrorMessageHint
x, ErrorMessageHint -> HintCategory
hintCategory ErrorMessageHint
y) of
        (HintCategory
OtherHint, HintCategory
_) -> Bool
False
        (HintCategory
_, HintCategory
OtherHint) -> Bool
False
        (HintCategory
c1, HintCategory
c2) -> HintCategory
c1 forall a. Eq a => a -> a -> Bool
== HintCategory
c2

    -- See https://github.com/purescript/purescript/issues/1802
    stripRedundantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
    stripRedundantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
stripRedundantHints ExprDoesNotHaveType{} = (ErrorMessageHint -> Bool)
-> [ErrorMessageHint] -> [ErrorMessageHint]
stripFirst ErrorMessageHint -> Bool
isCheckHint
      where
      isCheckHint :: ErrorMessageHint -> Bool
isCheckHint ErrorCheckingType{} = Bool
True
      isCheckHint ErrorMessageHint
_ = Bool
False
    stripRedundantHints TypesDoNotUnify{} = (ErrorMessageHint -> Bool)
-> [ErrorMessageHint] -> [ErrorMessageHint]
stripFirst ErrorMessageHint -> Bool
isUnifyHint
      where
      isUnifyHint :: ErrorMessageHint -> Bool
isUnifyHint ErrorUnifyingTypes{} = Bool
True
      isUnifyHint ErrorMessageHint
_ = Bool
False
    stripRedundantHints (NoInstanceFound (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
C.Coercible [Type SourceAnn]
_ [Type SourceAnn]
args Maybe ConstraintData
_) [Qualified (Either (Type SourceAnn) Ident)]
_ UnknownsHint
_) = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> Bool
isSolverHint)
      where
      isSolverHint :: ErrorMessageHint -> Bool
isSolverHint (ErrorSolvingConstraint (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
C.Coercible [Type SourceAnn]
_ [Type SourceAnn]
args' Maybe ConstraintData
_)) = [Type SourceAnn]
args forall a. Eq a => a -> a -> Bool
== [Type SourceAnn]
args'
      isSolverHint ErrorMessageHint
_ = Bool
False
    stripRedundantHints NoInstanceFound{} = (ErrorMessageHint -> Bool)
-> [ErrorMessageHint] -> [ErrorMessageHint]
stripFirst ErrorMessageHint -> Bool
isSolverHint
      where
      isSolverHint :: ErrorMessageHint -> Bool
isSolverHint ErrorSolvingConstraint{} = Bool
True
      isSolverHint ErrorMessageHint
_ = Bool
False
    stripRedundantHints SimpleErrorMessage
_ = forall a. a -> a
id

    stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]
    stripFirst :: (ErrorMessageHint -> Bool)
-> [ErrorMessageHint] -> [ErrorMessageHint]
stripFirst ErrorMessageHint -> Bool
p (PositionedError NonEmpty SourceSpan
pos : [ErrorMessageHint]
hs) = NonEmpty SourceSpan -> ErrorMessageHint
PositionedError NonEmpty SourceSpan
pos forall a. a -> [a] -> [a]
: (ErrorMessageHint -> Bool)
-> [ErrorMessageHint] -> [ErrorMessageHint]
stripFirst ErrorMessageHint -> Bool
p [ErrorMessageHint]
hs
    stripFirst ErrorMessageHint -> Bool
p (ErrorInModule ModuleName
mn    : [ErrorMessageHint]
hs) = ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn    forall a. a -> [a] -> [a]
: (ErrorMessageHint -> Bool)
-> [ErrorMessageHint] -> [ErrorMessageHint]
stripFirst ErrorMessageHint -> Bool
p [ErrorMessageHint]
hs
    stripFirst ErrorMessageHint -> Bool
p (ErrorMessageHint
hint                : [ErrorMessageHint]
hs)
      | ErrorMessageHint -> Bool
p ErrorMessageHint
hint = [ErrorMessageHint]
hs
      | Bool
otherwise = ErrorMessageHint
hint forall a. a -> [a] -> [a]
: [ErrorMessageHint]
hs
    stripFirst ErrorMessageHint -> Bool
_ [] = []

  hintCategory :: ErrorMessageHint -> HintCategory
  hintCategory :: ErrorMessageHint -> HintCategory
hintCategory ErrorCheckingType{}                  = HintCategory
ExprHint
  hintCategory ErrorInferringType{}                 = HintCategory
ExprHint
  hintCategory ErrorInExpression{}                  = HintCategory
ExprHint
  hintCategory ErrorUnifyingTypes{}                 = HintCategory
CheckHint
  hintCategory ErrorInSubsumption{}                 = HintCategory
CheckHint
  hintCategory ErrorInApplication{}                 = HintCategory
CheckHint
  hintCategory ErrorCheckingKind{}                  = HintCategory
CheckHint
  hintCategory ErrorSolvingConstraint{}             = HintCategory
SolverHint
  hintCategory PositionedError{}                    = HintCategory
PositionHint
  hintCategory ErrorInDataConstructor{}             = HintCategory
DeclarationHint
  hintCategory ErrorInTypeConstructor{}             = HintCategory
DeclarationHint
  hintCategory ErrorInBindingGroup{}                = HintCategory
DeclarationHint
  hintCategory ErrorInDataBindingGroup{}            = HintCategory
DeclarationHint
  hintCategory ErrorInTypeSynonym{}                 = HintCategory
DeclarationHint
  hintCategory ErrorInValueDeclaration{}            = HintCategory
DeclarationHint
  hintCategory ErrorInTypeDeclaration{}             = HintCategory
DeclarationHint
  hintCategory ErrorInTypeClassDeclaration{}        = HintCategory
DeclarationHint
  hintCategory ErrorInKindDeclaration{}             = HintCategory
DeclarationHint
  hintCategory ErrorInRoleDeclaration{}             = HintCategory
DeclarationHint
  hintCategory ErrorInForeignImport{}               = HintCategory
DeclarationHint
  hintCategory ErrorMessageHint
_                                    = HintCategory
OtherHint

  prettyPrintPlainIdent :: Ident -> Text
  prettyPrintPlainIdent :: Ident -> Text
prettyPrintPlainIdent Ident
ident =
    if Ident -> Bool
isPlainIdent Ident
ident
    then Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> Text
markCode (Ident -> Text
showIdent Ident
ident)
    else Text
""

  prettyInstanceName :: Qualified (Either SourceType Ident) -> Box.Box
  prettyInstanceName :: Qualified (Either (Type SourceAnn) Ident) -> Box
prettyInstanceName = \case
    Qualified QualifiedBy
qb (Left Type SourceAnn
ty) ->
      Box
"instance "
        Box -> Box -> Box
Box.<> (case QualifiedBy
qb of
                  ByModuleName ModuleName
mn -> Box
"in module "
                    Box -> Box -> Box
Box.<> Text -> Box
line (Text -> Text
markCode forall a b. (a -> b) -> a -> b
$ ModuleName -> Text
runModuleName ModuleName
mn)
                    Box -> Box -> Box
Box.<> Box
" "
                  QualifiedBy
_ -> Box
Box.nullBox)
        Box -> Box -> Box
Box.<> Box
"with type "
        Box -> Box -> Box
Box.<> Box -> Box
markCodeBox (forall a. Type a -> Box
prettyType Type SourceAnn
ty)
        Box -> Box -> Box
Box.<> Box
" "
        Box -> Box -> Box
Box.<> (Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> Text
displayStartEndPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Type a -> a
getAnnForType Type SourceAnn
ty)
    Qualified QualifiedBy
mn (Right Ident
inst) -> Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
markCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
showIdent forall a b. (a -> b) -> a -> b
$ forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn Ident
inst

  -- As of this writing, this function assumes that all provided SourceSpans
  -- are non-overlapping (except for exact duplicates) and span no line breaks. A
  -- more sophisticated implementation without this limitation would be possible
  -- but isn't yet needed.
  showSourceSpansInContext :: NonEmpty SourceSpan -> Box.Box
  showSourceSpansInContext :: NonEmpty SourceSpan -> Box
showSourceSpansInContext
    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Box
Box.nullBox (forall (f :: * -> *). Foldable f => f Box -> Box
paras forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty SourceSpan -> Box
renderFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Eq b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)
NEL.groupWith1 SourceSpan -> FilePath
spanName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => NonEmpty a -> NonEmpty a
NEL.sort)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> NonEmpty a -> [a]
NEL.filter ((forall a. Ord a => a -> a -> Bool
> Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Int
sourcePosLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
spanStart)
    where
    renderFile :: NonEmpty SourceSpan -> Box.Box
    renderFile :: NonEmpty SourceSpan -> Box
renderFile NonEmpty SourceSpan
sss = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Box
Box.nullBox ([Text] -> Box
linesToBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
fileName [(FilePath, Text)]
fileContents
      where
      fileName :: FilePath
fileName = SourceSpan -> FilePath
spanName forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NEL.head NonEmpty SourceSpan
sss
      header :: Box
header = FilePath -> Box
lineS forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> FilePath
":") forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
makeRelative FilePath
relPath forall a b. (a -> b) -> a -> b
$ FilePath
fileName
      lineBlocks :: NonEmpty (NonEmpty (Int, [SourceSpan]))
lineBlocks = NonEmpty (NonEmpty SourceSpan)
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
makeLineBlocks forall a b. (a -> b) -> a -> b
$ forall b a. Eq b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)
NEL.groupWith1 (SourcePos -> Int
sourcePosLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
spanStart) NonEmpty SourceSpan
sss

      linesToBox :: [Text] -> Box
linesToBox [Text]
fileLines = Int -> Box -> Box
Box.moveUp Int
1 forall a b. (a -> b) -> a -> b
$ Box
header Box -> Box -> Box
Box.// Box
body
        where
        body :: Box
body
          = forall (f :: * -> *).
Foldable f =>
Alignment -> Box -> f Box -> Box
Box.punctuateV Alignment
Box.left (FilePath -> Box
lineNumberStyle FilePath
"...")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *). Foldable f => f Box -> Box
paras forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Text, [SourceSpan]) -> Box
renderLine)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState ([Text]
fileLines, Int
1)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
wither (\(Int
i, [SourceSpan]
x) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
i, , [SourceSpan]
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> State ([a], Int) (Maybe a)
ascLookupInState Int
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NEL.toList)
          forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (NonEmpty (Int, [SourceSpan]))
lineBlocks

    makeLineBlocks :: NonEmpty (NonEmpty SourceSpan) -> NonEmpty (NonEmpty (Int, [SourceSpan]))
    makeLineBlocks :: NonEmpty (NonEmpty SourceSpan)
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
makeLineBlocks = NonEmpty (NonEmpty SourceSpan)
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
startBlock
      where
      startBlock :: NonEmpty (NonEmpty SourceSpan)
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
startBlock (NonEmpty SourceSpan
h :| [NonEmpty SourceSpan]
t) = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (t :: * -> *) a. Traversable1 t => Lens' (t a) a
head1 (forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons (forall a. Enum a => a -> a
pred forall a b. (a -> b) -> a -> b
$ NonEmpty SourceSpan -> Int
headLineNumber NonEmpty SourceSpan
h, [])) forall a b. (a -> b) -> a -> b
$ NonEmpty SourceSpan
-> [NonEmpty SourceSpan] -> NonEmpty (NonEmpty (Int, [SourceSpan]))
continueBlock NonEmpty SourceSpan
h [NonEmpty SourceSpan]
t

      continueBlock :: NonEmpty SourceSpan -> [NonEmpty SourceSpan] -> NonEmpty (NonEmpty (Int, [SourceSpan]))
      continueBlock :: NonEmpty SourceSpan
-> [NonEmpty SourceSpan] -> NonEmpty (NonEmpty (Int, [SourceSpan]))
continueBlock NonEmpty SourceSpan
lineGroup = \case
        [] ->
          NonEmpty SourceSpan
-> [NonEmpty (Int, [SourceSpan])]
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
endBlock NonEmpty SourceSpan
lineGroup []
        NonEmpty SourceSpan
nextGroup : [NonEmpty SourceSpan]
groups -> case forall a. Enum a => a -> a
pred forall a b. (a -> b) -> a -> b
$ ((-) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NonEmpty SourceSpan -> Int
headLineNumber) NonEmpty SourceSpan
nextGroup NonEmpty SourceSpan
lineGroup of
          Int
n | Int
n forall a. Ord a => a -> a -> Bool
<= Int
3 ->
            forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (t :: * -> *) a. Traversable1 t => Lens' (t a) a
head1 (Int -> NonEmpty SourceSpan -> NonEmpty (Int, [SourceSpan])
appendExtraLines Int
n NonEmpty SourceSpan
lineGroup forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ NonEmpty SourceSpan
-> [NonEmpty SourceSpan] -> NonEmpty (NonEmpty (Int, [SourceSpan]))
continueBlock NonEmpty SourceSpan
nextGroup [NonEmpty SourceSpan]
groups
          Int
_ ->
            NonEmpty SourceSpan
-> [NonEmpty (Int, [SourceSpan])]
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
endBlock NonEmpty SourceSpan
lineGroup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NEL.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty SourceSpan)
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
startBlock forall a b. (a -> b) -> a -> b
$ NonEmpty SourceSpan
nextGroup forall a. a -> [a] -> NonEmpty a
:| [NonEmpty SourceSpan]
groups

      endBlock :: NonEmpty SourceSpan -> [NonEmpty (Int, [SourceSpan])] -> NonEmpty (NonEmpty (Int, [SourceSpan]))
      endBlock :: NonEmpty SourceSpan
-> [NonEmpty (Int, [SourceSpan])]
-> NonEmpty (NonEmpty (Int, [SourceSpan]))
endBlock NonEmpty SourceSpan
h [NonEmpty (Int, [SourceSpan])]
t = Int -> NonEmpty SourceSpan -> NonEmpty (Int, [SourceSpan])
appendExtraLines Int
1 NonEmpty SourceSpan
h forall a. a -> [a] -> NonEmpty a
:| [NonEmpty (Int, [SourceSpan])]
t

      headLineNumber :: NonEmpty SourceSpan -> Int
headLineNumber = SourcePos -> Int
sourcePosLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
spanStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NEL.head

      appendExtraLines :: Int -> NonEmpty SourceSpan -> NonEmpty (Int, [SourceSpan])
      appendExtraLines :: Int -> NonEmpty SourceSpan -> NonEmpty (Int, [SourceSpan])
appendExtraLines Int
n NonEmpty SourceSpan
lineGroup = (Int
lineNum, forall a. NonEmpty a -> [a]
NEL.toList NonEmpty SourceSpan
lineGroup) forall a. a -> [a] -> NonEmpty a
:| [(Int
lineNum forall a. Num a => a -> a -> a
+ Int
i, []) | Int
i <- [Int
1..Int
n]]
        where
        lineNum :: Int
lineNum = NonEmpty SourceSpan -> Int
headLineNumber NonEmpty SourceSpan
lineGroup

    renderLine :: (Int, Text, [SourceSpan]) -> Box.Box
    renderLine :: (Int, Text, [SourceSpan]) -> Box
renderLine (Int
lineNum, Text
text, [SourceSpan]
sss) = Box
numBox Box -> Box -> Box
Box.<+> Box
lineBox
      where
      colSpans :: [(Int, Int)]
colSpans = forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (forall a. Enum a => a -> a
pred forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Int
sourcePosColumn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceSpan -> SourcePos
spanStart forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SourceSpan -> SourcePos
spanEnd)) [SourceSpan]
sss
      numBox :: Box
numBox = FilePath -> Box
lineNumberStyle forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show Int
lineNum
      lineBox :: Box
lineBox =
        if forall a. Maybe a -> Bool
isJust Maybe (ColorIntensity, Color)
codeColor
        then Maybe (ColorIntensity, Color) -> Box -> Box
colorCodeBox Maybe (ColorIntensity, Color)
codeColor forall a b. (a -> b) -> a -> b
$ Text -> Box
line forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int) -> Text -> Text
highlightSpan Text
text [(Int, Int)]
colSpans
        else Text -> Box
line Text
text Box -> Box -> Box
Box.// Text -> Box
line ((Int, Text) -> Text
finishUnderline forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int) -> (Int, Text) -> (Int, Text)
underlineSpan (Text -> Int
T.length Text
text, Text
"") [(Int, Int)]
colSpans)

    highlightSpan :: (Int, Int) -> Text -> Text
    highlightSpan :: (Int, Int) -> Text -> Text
highlightSpan (Int
startCol, Int
endCol) Text
text
       = Text
prefix
      forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([SGR] -> FilePath
ANSI.setSGRCode [Bool -> SGR
ANSI.SetSwapForegroundBackground Bool
True])
      forall a. Semigroup a => a -> a -> a
<> Text
spanText
      forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack ([SGR] -> FilePath
ANSI.setSGRCode [Bool -> SGR
ANSI.SetSwapForegroundBackground Bool
False])
      forall a. Semigroup a => a -> a -> a
<> Text
suffix
      where
      (Text
prefix, Text
rest) = Int -> Text -> (Text, Text)
T.splitAt Int
startCol Text
text
      (Text
spanText, Text
suffix) = Int -> Text -> (Text, Text)
T.splitAt (Int
endCol forall a. Num a => a -> a -> a
- Int
startCol) Text
rest

    underlineSpan :: (Int, Int) -> (Int, Text) -> (Int, Text)
    underlineSpan :: (Int, Int) -> (Int, Text) -> (Int, Text)
underlineSpan (Int
startCol, Int
endCol) (Int
len, Text
accum) = (Int
startCol, Int -> Text -> Text
T.replicate (Int
endCol forall a. Num a => a -> a -> a
- Int
startCol) Text
"^" forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
len forall a. Num a => a -> a -> a
- Int
endCol) Text
" " forall a. Semigroup a => a -> a -> a
<> Text
accum)

    finishUnderline :: (Int, Text) -> Text
    finishUnderline :: (Int, Text) -> Text
finishUnderline (Int
len, Text
accum) = Int -> Text -> Text
T.replicate Int
len Text
" " forall a. Semigroup a => a -> a -> a
<> Text
accum

    lineNumberStyle :: String -> Box.Box
    lineNumberStyle :: FilePath -> Box
lineNumberStyle = Maybe (ColorIntensity, Color) -> Box -> Box
colorCodeBox (Maybe (ColorIntensity, Color)
codeColor forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ColorIntensity
ANSI.Vivid, Color
ANSI.Black)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alignment -> Int -> Box -> Box
Box.alignHoriz Alignment
Box.right Int
5 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Box
lineS

  -- Lookup the nth element of a list, but without retraversing the list every
  -- time, by instead keeping a tail of the list and the current element number
  -- in State. Only works if the argument provided is strictly ascending over
  -- the life of the State.
  ascLookupInState :: forall a. Int -> State ([a], Int) (Maybe a)
  ascLookupInState :: forall a. Int -> State ([a], Int) (Maybe a)
ascLookupInState Int
j = forall (m :: * -> *) s. Monad m => StateT s m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \([a]
as, Int
i) -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a. [a] -> Maybe (a, [a])
uncons forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (Int
j forall a. Num a => a -> a -> a
- Int
i) [a]
as) forall a b. (a -> b) -> a -> b
$ \(a
a, [a]
as') -> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ([a]
as', forall a. Enum a => a -> a
succ Int
j) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
a

-- Pretty print and export declaration
prettyPrintExport :: DeclarationRef -> Text
prettyPrintExport :: DeclarationRef -> Text
prettyPrintExport (TypeRef SourceSpan
_ ProperName 'TypeName
pn Maybe [ProperName 'ConstructorName]
_) = forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
pn
prettyPrintExport DeclarationRef
ref =
  forall a. a -> Maybe a -> a
fromMaybe
    (forall a. HasCallStack => FilePath -> a
internalError FilePath
"prettyPrintRef returned Nothing in prettyPrintExport")
    (DeclarationRef -> Maybe Text
prettyPrintRef DeclarationRef
ref)

prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text
prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text
prettyPrintImport ModuleName
mn ImportDeclarationType
idt Maybe ModuleName
qual =
  let i :: Text
i = case ImportDeclarationType
idt of
            ImportDeclarationType
Implicit -> ModuleName -> Text
runModuleName ModuleName
mn
            Explicit [DeclarationRef]
refs -> ModuleName -> Text
runModuleName ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DeclarationRef -> Maybe Text
prettyPrintRef [DeclarationRef]
refs) forall a. Semigroup a => a -> a -> a
<> Text
")"
            Hiding [DeclarationRef]
refs -> ModuleName -> Text
runModuleName ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
" hiding (" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DeclarationRef -> Maybe Text
prettyPrintRef [DeclarationRef]
refs) forall a. Semigroup a => a -> a -> a
<> Text
")"
  in Text
i forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\ModuleName
q -> Text
" as " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
runModuleName ModuleName
q) Maybe ModuleName
qual

prettyPrintRef :: DeclarationRef -> Maybe Text
prettyPrintRef :: DeclarationRef -> Maybe Text
prettyPrintRef (TypeRef SourceSpan
_ ProperName 'TypeName
pn Maybe [ProperName 'ConstructorName]
Nothing) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
pn forall a. Semigroup a => a -> a -> a
<> Text
"(..)"
prettyPrintRef (TypeRef SourceSpan
_ ProperName 'TypeName
pn (Just [])) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
pn
prettyPrintRef (TypeRef SourceSpan
_ ProperName 'TypeName
pn (Just [ProperName 'ConstructorName]
dctors)) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'TypeName
pn forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall (a :: ProperNameType). ProperName a -> Text
runProperName [ProperName 'ConstructorName]
dctors) forall a. Semigroup a => a -> a -> a
<> Text
")"
prettyPrintRef (TypeOpRef SourceSpan
_ OpName 'TypeOpName
op) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"type " forall a. Semigroup a => a -> a -> a
<> forall (a :: OpNameType). OpName a -> Text
showOp OpName 'TypeOpName
op
prettyPrintRef (ValueRef SourceSpan
_ Ident
ident) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Ident -> Text
showIdent Ident
ident
prettyPrintRef (ValueOpRef SourceSpan
_ OpName 'ValueOpName
op) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (a :: OpNameType). OpName a -> Text
showOp OpName 'ValueOpName
op
prettyPrintRef (TypeClassRef SourceSpan
_ ProperName 'ClassName
pn) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"class " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'ClassName
pn
prettyPrintRef (TypeInstanceRef SourceSpan
_ Ident
ident NameSource
UserNamed) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Ident -> Text
showIdent Ident
ident
prettyPrintRef (TypeInstanceRef SourceSpan
_ Ident
_ NameSource
CompilerNamed) =
  forall a. Maybe a
Nothing
prettyPrintRef (ModuleRef SourceSpan
_ ModuleName
name) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"module " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
runModuleName ModuleName
name
prettyPrintRef ReExportRef{} =
  forall a. Maybe a
Nothing

prettyPrintKindSignatureFor :: KindSignatureFor -> Text
prettyPrintKindSignatureFor :: KindSignatureFor -> Text
prettyPrintKindSignatureFor KindSignatureFor
DataSig = Text
"data"
prettyPrintKindSignatureFor KindSignatureFor
NewtypeSig = Text
"newtype"
prettyPrintKindSignatureFor KindSignatureFor
TypeSynonymSig = Text
"type"
prettyPrintKindSignatureFor KindSignatureFor
ClassSig = Text
"class"

prettyPrintSuggestedTypeSimplified :: Type a -> String
prettyPrintSuggestedTypeSimplified :: forall a. Type a -> FilePath
prettyPrintSuggestedTypeSimplified = forall a. Type a -> FilePath
prettyPrintSuggestedType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
eraseForAllKindAnnotations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> Type a
eraseKindApps

-- | Pretty print multiple errors
prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String
prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> FilePath
prettyPrintMultipleErrors PPEOptions
ppeOptions = [FilePath] -> FilePath
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Box -> FilePath
renderBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. PPEOptions -> MultipleErrors -> [Box]
prettyPrintMultipleErrorsBox PPEOptions
ppeOptions

-- | Pretty print multiple warnings
prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String
prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> FilePath
prettyPrintMultipleWarnings PPEOptions
ppeOptions = [FilePath] -> FilePath
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Box -> FilePath
renderBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. PPEOptions -> MultipleErrors -> [Box]
prettyPrintMultipleWarningsBox PPEOptions
ppeOptions

-- | Pretty print warnings as a Box
prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box]
prettyPrintMultipleWarningsBox PPEOptions
ppeOptions = PPEOptions -> FilePath -> FilePath -> MultipleErrors -> [Box]
prettyPrintMultipleErrorsWith (PPEOptions
ppeOptions { ppeLevel :: Level
ppeLevel = Level
Warning }) FilePath
"Warning found:" FilePath
"Warning"

-- | Pretty print errors as a Box
prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box.Box]
prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box]
prettyPrintMultipleErrorsBox PPEOptions
ppeOptions = PPEOptions -> FilePath -> FilePath -> MultipleErrors -> [Box]
prettyPrintMultipleErrorsWith (PPEOptions
ppeOptions { ppeLevel :: Level
ppeLevel = Level
Error }) FilePath
"Error found:" FilePath
"Error"

prettyPrintMultipleErrorsWith :: PPEOptions -> String -> String -> MultipleErrors -> [Box.Box]
prettyPrintMultipleErrorsWith :: PPEOptions -> FilePath -> FilePath -> MultipleErrors -> [Box]
prettyPrintMultipleErrorsWith PPEOptions
ppeOptions FilePath
intro FilePath
_ (MultipleErrors [ErrorMessage
e]) =
  let result :: Box
result = PPEOptions -> ErrorMessage -> Box
prettyPrintSingleError PPEOptions
ppeOptions ErrorMessage
e
  in [ forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left [ FilePath -> Box
Box.text FilePath
intro
                         , Box
result
                         ]
     ]
prettyPrintMultipleErrorsWith PPEOptions
ppeOptions FilePath
_ FilePath
intro (MultipleErrors [ErrorMessage]
es) =
  let result :: [Box]
result = forall a b. (a -> b) -> [a] -> [b]
map (PPEOptions -> ErrorMessage -> Box
prettyPrintSingleError PPEOptions
ppeOptions) [ErrorMessage]
es
  in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Box -> [Box]
withIntro [Int
1 :: Int ..] [Box]
result
  where
  withIntro :: Int -> Box -> [Box]
withIntro Int
i Box
err = [ FilePath -> Box
Box.text (FilePath
intro forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
i forall a. [a] -> [a] -> [a]
++ FilePath
" of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ErrorMessage]
es) forall a. [a] -> [a] -> [a]
++ FilePath
":")
                    , Int -> Box -> Box
Box.moveRight Int
2 Box
err
                    ]

-- | Indent to the right, and pad on top and bottom.
indent :: Box.Box -> Box.Box
indent :: Box -> Box
indent = Int -> Box -> Box
Box.moveUp Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Box -> Box
Box.moveDown Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Box -> Box
Box.moveRight Int
2

line :: Text -> Box.Box
line :: Text -> Box
line = FilePath -> Box
Box.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack

lineS :: String -> Box.Box
lineS :: FilePath -> Box
lineS = FilePath -> Box
Box.text

renderBox :: Box.Box -> String
renderBox :: Box -> FilePath
renderBox = [FilePath] -> FilePath
unlines
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile FilePath -> Bool
whiteSpace
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd FilePath -> Bool
whiteSpace
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> FilePath
Box.render
  where
  whiteSpace :: FilePath -> Bool
whiteSpace = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace

toTypelevelString :: Type a -> Maybe Box.Box
toTypelevelString :: forall a. Type a -> Maybe Box
toTypelevelString (TypeLevelString a
_ PSString
s) =
  forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Box
Box.text forall a b. (a -> b) -> a -> b
$ PSString -> FilePath
decodeStringWithReplacement PSString
s
toTypelevelString (TypeApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
C.Text) Type a
x) =
  forall a. Type a -> Maybe Box
toTypelevelString Type a
x
toTypelevelString (TypeApp a
_ (KindApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
C.Quote) Type a
_) Type a
x) =
  forall a. a -> Maybe a
Just (forall a. Int -> Type a -> Box
typeAsBox forall a. Bounded a => a
maxBound Type a
x)
toTypelevelString (TypeApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
C.QuoteLabel) (TypeLevelString a
_ PSString
x)) =
  forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Box
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Text
prettyPrintLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSString -> Label
Label forall a b. (a -> b) -> a -> b
$ PSString
x
toTypelevelString (TypeApp a
_ (TypeApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
C.Beside) Type a
x) Type a
ret) =
  Box -> Box -> Box
(Box.<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Type a -> Maybe Box
toTypelevelString Type a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Type a -> Maybe Box
toTypelevelString Type a
ret
toTypelevelString (TypeApp a
_ (TypeApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
C.Above) Type a
x) Type a
ret) =
  Box -> Box -> Box
(Box.//) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Type a -> Maybe Box
toTypelevelString Type a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Type a -> Maybe Box
toTypelevelString Type a
ret
toTypelevelString Type a
_ = forall a. Maybe a
Nothing

-- | Rethrow an error with a more detailed error message in the case of failure
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow :: forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow e -> e
f = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e
f)

warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a
warnAndRethrow :: forall e (m :: * -> *) a.
(MonadError e m, MonadWriter e m) =>
(e -> e) -> m a -> m a
warnAndRethrow e -> e
f = forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow e -> e
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor e -> e
f

-- | Rethrow an error with source position information
rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
rethrowWithPosition :: forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
pos = forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow ((ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
onErrorMessages (SourceSpan -> ErrorMessage -> ErrorMessage
withPosition SourceSpan
pos))

warnWithPosition :: (MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a
warnWithPosition :: forall (m :: * -> *) a.
MonadWriter MultipleErrors m =>
SourceSpan -> m a -> m a
warnWithPosition SourceSpan
pos = forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor ((ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
onErrorMessages (SourceSpan -> ErrorMessage -> ErrorMessage
withPosition SourceSpan
pos))

warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceSpan -> m a -> m a
warnAndRethrowWithPosition :: forall (m :: * -> *) a.
(MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
SourceSpan -> m a -> m a
warnAndRethrowWithPosition SourceSpan
pos = forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadWriter MultipleErrors m =>
SourceSpan -> m a -> m a
warnWithPosition SourceSpan
pos

withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
withPosition SourceSpan
NullSourceSpan ErrorMessage
err = ErrorMessage
err
withPosition SourceSpan
pos (ErrorMessage [ErrorMessageHint]
hints SimpleErrorMessage
se) = [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
pos forall a. a -> [a] -> [a]
: [ErrorMessageHint]
hints) SimpleErrorMessage
se

withoutPosition :: ErrorMessage -> ErrorMessage
withoutPosition :: ErrorMessage -> ErrorMessage
withoutPosition (ErrorMessage [ErrorMessageHint]
hints SimpleErrorMessage
se) = [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage (forall a. (a -> Bool) -> [a] -> [a]
filter ErrorMessageHint -> Bool
go [ErrorMessageHint]
hints) SimpleErrorMessage
se
  where
  go :: ErrorMessageHint -> Bool
go (PositionedError NonEmpty SourceSpan
_) = Bool
False
  go ErrorMessageHint
_ = Bool
True

positionedError :: SourceSpan -> ErrorMessageHint
positionedError :: SourceSpan -> ErrorMessageHint
positionedError = NonEmpty SourceSpan -> ErrorMessageHint
PositionedError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Runs a computation listening for warnings and then escalating any warnings
-- that match the predicate to error status.
escalateWarningWhen
  :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m)
  => (ErrorMessage -> Bool)
  -> m a
  -> m a
escalateWarningWhen :: forall (m :: * -> *) a.
(MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
(ErrorMessage -> Bool) -> m a -> m a
escalateWarningWhen ErrorMessage -> Bool
isError m a
ma = do
  (a
a, MultipleErrors
w) <- forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m a
ma
  let ([ErrorMessage]
errors, [ErrorMessage]
warnings) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ErrorMessage -> Bool
isError (MultipleErrors -> [ErrorMessage]
runMultipleErrors MultipleErrors
w)
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ [ErrorMessage] -> MultipleErrors
MultipleErrors [ErrorMessage]
warnings
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMessage]
errors) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [ErrorMessage] -> MultipleErrors
MultipleErrors [ErrorMessage]
errors
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Collect errors in in parallel
parU
  :: forall m a b
   . MonadError MultipleErrors m
  => [a]
  -> (a -> m b)
  -> m [b]
parU :: forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU [a]
xs a -> m b
f =
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [a]
xs (m b -> m (Either MultipleErrors b)
withError forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Either MultipleErrors b] -> m [b]
collectErrors
  where
    withError :: m b -> m (Either MultipleErrors b)
    withError :: m b -> m (Either MultipleErrors b)
withError m b
u = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
u) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

    collectErrors :: [Either MultipleErrors b] -> m [b]
    collectErrors :: [Either MultipleErrors b] -> m [b]
collectErrors [Either MultipleErrors b]
es = case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either MultipleErrors b]
es of
      ([], [b]
rs) -> forall (m :: * -> *) a. Monad m => a -> m a
return [b]
rs
      ([MultipleErrors]
errs, [b]
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [MultipleErrors]
errs

internalCompilerError
  :: (MonadError MultipleErrors m, GHC.Stack.HasCallStack)
  => Text
  -> m a
internalCompilerError :: forall (m :: * -> *) a.
(MonadError MultipleErrors m, HasCallStack) =>
Text -> m a
internalCompilerError =
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> SimpleErrorMessage
InternalCompilerError (FilePath -> Text
T.pack (CallStack -> FilePath
GHC.Stack.prettyCallStack HasCallStack => CallStack
GHC.Stack.callStack))