{-# LANGUAGE ExistentialQuantification #-}

module GHC.Parser.Errors.Types where

import GHC.Prelude

import Data.Typeable

import GHC.Core.TyCon (Role)
import GHC.Data.FastString
import GHC.Hs
import GHC.Parser.Types
import GHC.Types.Error
import GHC.Types.Name.Occurrence (OccName)
import GHC.Types.Name.Reader
import GHC.Unit.Module.Name
import GHC.Utils.Outputable

-- The type aliases below are useful to make some type signatures a bit more
-- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'.

type PsWarning = PsMessage   -- /INVARIANT/: The diagnosticReason is a Warning reason
type PsError   = PsMessage   -- /INVARIANT/: The diagnosticReason is ErrorWithoutFlag

data PsMessage
  =
    {-| An \"unknown\" message from the parser. This type constructor allows
        arbitrary messages to be embedded. The typical use case would be GHC plugins
        willing to emit custom diagnostics.
    -}
   forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a

   {-| PsWarnTab is a warning (controlled by the -Wwarn-tabs flag) that occurs
       when tabulations (tabs) are found within a file.

       Test case(s): parser/should_fail/T12610
                     parser/should_compile/T9723b
                     parser/should_compile/T9723a
                     parser/should_compile/read043
                     parser/should_fail/T16270
                     warnings/should_compile/T9230

   -}
   | PsWarnTab !Word -- ^ Number of other occurrences other than the first one

   {-| PsWarnTransitionalLayout is a warning (controlled by the
       -Walternative-layout-rule-transitional flag) that occurs when pipes ('|')
       or 'where' are at the same depth of an implicit layout block.

       Example(s):

          f :: IO ()
          f
           | True = do
           let x = ()
               y = ()
           return ()
           | True = return ()

       Test case(s): layout/layout006
                     layout/layout003
                     layout/layout001

   -}
   | PsWarnTransitionalLayout !TransLayoutReason

   -- | Unrecognised pragma
   | PsWarnUnrecognisedPragma

   -- | Invalid Haddock comment position
   | PsWarnHaddockInvalidPos

   -- | Multiple Haddock comment for the same entity
   | PsWarnHaddockIgnoreMulti

   -- | Found binding occurrence of "*" while StarIsType is enabled
   | PsWarnStarBinder

   -- | Using "*" for "Type" without StarIsType enabled
   | PsWarnStarIsType

   -- | Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled
   | PsWarnImportPreQualified

   | PsWarnOperatorWhitespaceExtConflict !OperatorWhitespaceSymbol

   | PsWarnOperatorWhitespace !FastString !OperatorWhitespaceOccurrence

   -- | LambdaCase syntax used without the extension enabled
   | PsErrLambdaCase

   -- | A lambda requires at least one parameter
   | PsErrEmptyLambda

   -- | Underscores in literals without the extension enabled
   | PsErrNumUnderscores !NumUnderscoreReason

   -- | Invalid character in primitive string
   | PsErrPrimStringInvalidChar

   -- | Missing block
   | PsErrMissingBlock

   -- | Lexer error
   | PsErrLexer !LexErr !LexErrKind

   -- | Suffix occurrence of `@`
   | PsErrSuffixAT

   -- | Parse errors
   | PsErrParse !String !PsErrParseDetails

   -- | Cmm lexer error
   | PsErrCmmLexer

   -- | Unsupported boxed sum in expression
   | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))

   -- | Unsupported boxed sum in pattern
   | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))

   -- | Unexpected qualified constructor
   | PsErrUnexpectedQualifiedConstructor !RdrName

   -- | Tuple section in pattern context
   | PsErrTupleSectionInPat

   -- | Bang-pattern without BangPattterns enabled
   | PsErrIllegalBangPattern !(Pat GhcPs)

   -- | Operator applied to too few arguments
   | PsErrOpFewArgs !StarIsType !RdrName

   -- | Import: multiple occurrences of 'qualified'
   | PsErrImportQualifiedTwice

   -- | Post qualified import without 'ImportQualifiedPost'
   | PsErrImportPostQualified

   -- | Explicit namespace keyword without 'ExplicitNamespaces'
   | PsErrIllegalExplicitNamespace

   -- | Expecting a type constructor but found a variable
   | PsErrVarForTyCon !RdrName

   -- | Illegal export form allowed by PatternSynonyms
   | PsErrIllegalPatSynExport

   -- | Malformed entity string
   | PsErrMalformedEntityString

   -- | Dots used in record update
   | PsErrDotsInRecordUpdate

   -- | Precedence out of range
   | PsErrPrecedenceOutOfRange !Int

   -- | Invalid use of record dot syntax `.'
   | PsErrOverloadedRecordDotInvalid

   -- | `OverloadedRecordUpdate` is not enabled.
   | PsErrOverloadedRecordUpdateNotEnabled

   -- | Can't use qualified fields when OverloadedRecordUpdate is enabled.
   | PsErrOverloadedRecordUpdateNoQualifiedFields

   -- | Cannot parse data constructor in a data/newtype declaration
   | PsErrInvalidDataCon !(HsType GhcPs)

   -- | Cannot parse data constructor in a data/newtype declaration
   | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)

   -- | UNPACK applied to a data constructor
   | PsErrUnpackDataCon

   -- | Unexpected kind application in data/newtype declaration
   | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)

   -- | Not a record constructor
   | PsErrInvalidRecordCon !(PatBuilder GhcPs)

   -- | Illegal unboxed string literal in pattern
   | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)

   -- | Do-notation in pattern
   | PsErrDoNotationInPat

   -- | If-then-else syntax in pattern
   | PsErrIfThenElseInPat

   -- | Lambda-case in pattern
   | PsErrLambdaCaseInPat

   -- | case..of in pattern
   | PsErrCaseInPat

   -- | let-syntax in pattern
   | PsErrLetInPat

   -- | Lambda-syntax in pattern
   | PsErrLambdaInPat

   -- | Arrow expression-syntax in pattern
   | PsErrArrowExprInPat !(HsExpr GhcPs)

   -- | Arrow command-syntax in pattern
   | PsErrArrowCmdInPat !(HsCmd GhcPs)

   -- | Arrow command-syntax in expression
   | PsErrArrowCmdInExpr !(HsCmd GhcPs)

   -- | View-pattern in expression
   | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)

   -- | Type-application without space before '@'
   | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)

   -- | Lazy-pattern ('~') without space after it
   | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs)

   -- | Bang-pattern ('!') without space after it
   | PsErrBangPatWithoutSpace !(LHsExpr GhcPs)

   -- | Pragma not allowed in this position
   | PsErrUnallowedPragma !(HsPragE GhcPs)

   -- | Qualified do block in command
   | PsErrQualifiedDoInCmd !ModuleName

   -- | Invalid infix hole, expected an infix operator
   | PsErrInvalidInfixHole

   -- | Unexpected semi-colons in conditional expression
   | PsErrSemiColonsInCondExpr
       !(HsExpr GhcPs) -- ^ conditional expr
       !Bool           -- ^ "then" semi-colon?
       !(HsExpr GhcPs) -- ^ "then" expr
       !Bool           -- ^ "else" semi-colon?
       !(HsExpr GhcPs) -- ^ "else" expr

   -- | Unexpected semi-colons in conditional command
   | PsErrSemiColonsInCondCmd
       !(HsExpr GhcPs) -- ^ conditional expr
       !Bool           -- ^ "then" semi-colon?
       !(HsCmd GhcPs)  -- ^ "then" expr
       !Bool           -- ^ "else" semi-colon?
       !(HsCmd GhcPs)  -- ^ "else" expr

   -- | @-operator in a pattern position
   | PsErrAtInPatPos

   -- | Unexpected lambda command in function application
   | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)

   -- | Unexpected case command in function application
   | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)

   -- | Unexpected if command in function application
   | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)

   -- | Unexpected let command in function application
   | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs)

   -- | Unexpected do command in function application
   | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs)

   -- | Unexpected do block in function application
   | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)

   -- | Unexpected mdo block in function application
   | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)

   -- | Unexpected lambda expression in function application
   | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)

   -- | Unexpected case expression in function application
   | PsErrCaseInFunAppExpr !(LHsExpr GhcPs)

   -- | Unexpected lambda-case expression in function application
   | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)

   -- | Unexpected let expression in function application
   | PsErrLetInFunAppExpr !(LHsExpr GhcPs)

   -- | Unexpected if expression in function application
   | PsErrIfInFunAppExpr !(LHsExpr GhcPs)

   -- | Unexpected proc expression in function application
   | PsErrProcInFunAppExpr !(LHsExpr GhcPs)

   -- | Malformed head of type or class declaration
   | PsErrMalformedTyOrClDecl !(LHsType GhcPs)

   -- | Illegal 'where' keyword in data declaration
   | PsErrIllegalWhereInDataDecl

   -- | Illegal datatype context
   | PsErrIllegalDataTypeContext !(LHsContext GhcPs)

   -- | Parse error on input
   | PsErrParseErrorOnInput !OccName

   -- | Malformed ... declaration for ...
   | PsErrMalformedDecl !SDoc !RdrName

   -- | Unexpected type application in a declaration
   | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName

   -- | Not a data constructor
   | PsErrNotADataCon !RdrName

   -- | Record syntax used in pattern synonym declaration
   | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs)

   -- | Empty 'where' clause in pattern-synonym declaration
   | PsErrEmptyWhereInPatSynDecl !RdrName

   -- | Invalid binding name in 'where' clause of pattern-synonym declaration
   | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)

   -- | Multiple bindings in 'where' clause of pattern-synonym declaration
   | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)

   -- | Declaration splice not a top-level
   | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)

   -- | Inferred type variables not allowed here
   | PsErrInferredTypeVarNotAllowed

   -- | Multiple names in standalone kind signatures
   | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]

   -- | Illegal import bundle form
   | PsErrIllegalImportBundleForm

   -- | Illegal role name
   | PsErrIllegalRoleName !FastString [Role]

   -- | Invalid type signature
   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)

   -- | Unexpected type in declaration
   | PsErrUnexpectedTypeInDecl !(LHsType GhcPs)
                               !SDoc
                               !RdrName
                               [LHsTypeArg GhcPs]
                               !SDoc

   -- | Expected a hyphen
   | PsErrExpectedHyphen

   -- | Found a space in a SCC
   | PsErrSpaceInSCC

   -- | Found two single quotes
   | PsErrEmptyDoubleQuotes !Bool
                            -- ^ Is TH on?

   -- | Invalid package name
   | PsErrInvalidPackageName !FastString

   -- | Invalid rule activation marker
   | PsErrInvalidRuleActivationMarker

   -- | Linear function found but LinearTypes not enabled
   | PsErrLinearFunction

   -- | Multi-way if-expression found but MultiWayIf not enabled
   | PsErrMultiWayIf

   -- | Explicit forall found but no extension allowing it is enabled
   | PsErrExplicitForall !Bool
                         -- ^ is Unicode forall?

   -- | Found qualified-do without QualifiedDo enabled
   | PsErrIllegalQualifiedDo !SDoc

   -- | Cmm parser error
   | PsErrCmmParser !CmmParserError

   -- | Illegal traditional record syntax
   --
   -- TODO: distinguish errors without using SDoc
   | PsErrIllegalTraditionalRecordSyntax !SDoc

   -- | Parse error in command
   --
   -- TODO: distinguish errors without using SDoc
   | PsErrParseErrorInCmd !SDoc

   -- | Parse error in pattern
   | PsErrInPat !(PatBuilder GhcPs) !PsErrInPatDetails

   -- | Parse error in right operator section pattern
   -- TODO: embed the proper operator, if possible
   | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs)

newtype StarIsType = StarIsType Bool

-- | Extra details about a parse error, which helps
-- us in determining which should be the hints to
-- suggest.
data PsErrParseDetails
  = PsErrParseDetails
  { ped_th_enabled :: !Bool
    -- Is 'TemplateHaskell' enabled?
  , ped_do_in_last_100 :: !Bool
    -- ^ Is there a 'do' in the last 100 characters?
  , ped_mdo_in_last_100 :: !Bool
    -- ^ Is there an 'mdo' in the last 100 characters?
  , ped_pat_syn_enabled :: !Bool
    -- ^ Is 'PatternSynonyms' enabled?
  , ped_pattern_parsed :: !Bool
    -- ^ Did we parse a \"pattern\" keyword?
  }

-- | Is the parsed pattern recursive?
data PatIsRecursive
  = YesPatIsRecursive
  | NoPatIsRecursive

data PatIncompleteDoBlock
  = YesIncompleteDoBlock
  | NoIncompleteDoBlock
  deriving Eq

-- | Extra information for the expression GHC is currently inspecting/parsing.
-- It can be used to generate more informative parser diagnostics and hints.
data ParseContext
  = ParseContext
  { is_infix :: !(Maybe RdrName)
    -- ^ If 'Just', this is an infix
    -- pattern with the binded operator name
  , incomplete_do_block :: !PatIncompleteDoBlock
    -- ^ Did the parser likely fail due to an incomplete do block?
  } deriving Eq

data PsErrInPatDetails
  = PEIP_NegApp
    -- ^ Negative application pattern?
  | PEIP_TypeArgs [HsPatSigType GhcPs]
    -- ^ The list of type arguments for the pattern
  | PEIP_RecPattern [LPat GhcPs]    -- ^ The pattern arguments
                    !PatIsRecursive -- ^ Is the parsed pattern recursive?
                    !ParseContext
  | PEIP_OtherPatDetails !ParseContext

noParseContext :: ParseContext
noParseContext = ParseContext Nothing NoIncompleteDoBlock

incompleteDoBlock :: ParseContext
incompleteDoBlock = ParseContext Nothing YesIncompleteDoBlock

-- | Builds a 'PsErrInPatDetails' with the information provided by the 'ParseContext'.
fromParseContext :: ParseContext -> PsErrInPatDetails
fromParseContext = PEIP_OtherPatDetails

data NumUnderscoreReason
   = NumUnderscore_Integral
   | NumUnderscore_Float
   deriving (Show,Eq,Ord)

data LexErrKind
   = LexErrKind_EOF        -- ^ End of input
   | LexErrKind_UTF8       -- ^ UTF-8 decoding error
   | LexErrKind_Char !Char -- ^ Error at given character
   deriving (Show,Eq,Ord)

data LexErr
   = LexError               -- ^ Lexical error
   | LexUnknownPragma       -- ^ Unknown pragma
   | LexErrorInPragma       -- ^ Lexical error in pragma
   | LexNumEscapeRange      -- ^ Numeric escape sequence out of range
   | LexStringCharLit       -- ^ Lexical error in string/character literal
   | LexStringCharLitEOF    -- ^ Unexpected end-of-file in string/character literal
   | LexUnterminatedComment -- ^ Unterminated `{-'
   | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma
   | LexUnterminatedQQ      -- ^ Unterminated quasiquotation

-- | Errors from the Cmm parser
data CmmParserError
   = CmmUnknownPrimitive    !FastString -- ^ Unknown Cmm primitive
   | CmmUnknownMacro        !FastString -- ^ Unknown macro
   | CmmUnknownCConv        !String     -- ^ Unknown calling convention
   | CmmUnrecognisedSafety  !String     -- ^ Unrecognised safety
   | CmmUnrecognisedHint    !String     -- ^ Unrecognised hint

-- | The operator symbol in the 'PsOperatorWhitespaceExtConflictMessage' diagnostic.
data OperatorWhitespaceSymbol
   = OperatorWhitespaceSymbol_PrefixPercent
   | OperatorWhitespaceSymbol_PrefixDollar
   | OperatorWhitespaceSymbol_PrefixDollarDollar

-- | The operator occurrence type in the 'PsOperatorWhitespaceMessage' diagnostic.
data OperatorWhitespaceOccurrence
   = OperatorWhitespaceOccurrence_Prefix
   | OperatorWhitespaceOccurrence_Suffix
   | OperatorWhitespaceOccurrence_TightInfix

data TransLayoutReason
   = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"
   | TransLayout_Pipe  -- ^ "`|' at the same depth as implicit layout block")