    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}

    -- | Parser for Haskell source code.
    module Ormolu.Parser
      ( parseModule,
        manualExts,
      )
    where

    import Bag (bagToList)
    import qualified CmdLineParser as GHC
    import Control.Exception
    import Control.Monad.IO.Class
    import qualified Data.List as L
    import qualified Data.List.NonEmpty as NE
    import Data.Ord (Down (Down))
    import qualified Data.Text as T
    import DynFlags as GHC
    import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
    import qualified FastString as GHC
    import GHC hiding (IE, UnicodeSyntax)
    import GHC.DynFlags (baseDynFlags)
    import GHC.LanguageExtensions.Type (Extension (..))
    import qualified HeaderInfo as GHC
    import qualified HscTypes as GHC
    import qualified Lexer as GHC
    import Ormolu.Config
    import Ormolu.Exception
    import Ormolu.Parser.Anns
    import Ormolu.Parser.CommentStream
    import Ormolu.Parser.Result
    import Ormolu.Processing.Preprocess (preprocess)
    import Ormolu.Utils (incSpanLine, removeIndentation)
    import qualified Panic as GHC
    import qualified Parser as GHC
    import qualified StringBuffer as GHC

    -- | Parse a complete module from string.
    parseModule ::
      MonadIO m =>
      -- | Ormolu configuration
      Config RegionDeltas ->
      -- | File name (only for source location annotations)
      FilePath ->
      -- | Input for parser
      String ->
      m
        ( [GHC.Warn],
          Either (SrcSpan, String) ParseResult
        )
    parseModule :: Config RegionDeltas
    -> FilePath
    -> FilePath
    -> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
    parseModule Config {..} path :: FilePath
    path rawInput :: FilePath
    rawInput = IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
    -> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
     -> m ([Warn], Either (SrcSpan, FilePath) ParseResult))
    -> IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
    -> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
    forall a b. (a -> b) -> a -> b
    $ do
      let (literalPrefix :: FilePath
    literalPrefix, indentedInput :: FilePath
    indentedInput, literalSuffix :: FilePath
    literalSuffix, extraComments :: [Located FilePath]
    extraComments) =
            FilePath
    -> FilePath
    -> RegionDeltas
    -> (FilePath, FilePath, FilePath, [Located FilePath])
    preprocess FilePath
    path FilePath
    rawInput RegionDeltas
    cfgRegion
          (input :: FilePath
    input, indent :: Int
    indent) = FilePath -> (FilePath, Int)
    removeIndentation FilePath
    indentedInput
      -- It's important that 'setDefaultExts' is done before
      -- 'parsePragmasIntoDynFlags', because otherwise we might enable an
      -- extension that was explicitly disabled in the file.
      let baseFlags :: DynFlags
    baseFlags =
            GeneralFlag -> DynFlags -> DynFlags
    GHC.setGeneralFlag'
              GeneralFlag
    GHC.Opt_Haddock
              (DynFlags -> DynFlags
    setDefaultExts DynFlags
    baseDynFlags)
          extraOpts :: [Located FilePath]
    extraOpts = DynOption -> Located FilePath
    dynOptionToLocatedStr (DynOption -> Located FilePath)
    -> [DynOption] -> [Located FilePath]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [DynOption]
    cfgDynOptions
      (warnings :: [Warn]
    warnings, dynFlags :: DynFlags
    dynFlags) <-
        DynFlags
    -> [Located FilePath]
    -> FilePath
    -> FilePath
    -> IO (Either FilePath ([Warn], DynFlags))
    parsePragmasIntoDynFlags DynFlags
    baseFlags [Located FilePath]
    extraOpts FilePath
    path FilePath
    rawInput IO (Either FilePath ([Warn], DynFlags))
    -> (Either FilePath ([Warn], DynFlags) -> IO ([Warn], DynFlags))
    -> IO ([Warn], DynFlags)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
          Right res :: ([Warn], DynFlags)
    res -> ([Warn], DynFlags) -> IO ([Warn], DynFlags)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([Warn], DynFlags)
    res
          Left err :: FilePath
    err ->
            let loc :: SrcSpan
    loc =
                  SrcLoc -> SrcLoc -> SrcSpan
    mkSrcSpan
                    (FastString -> Int -> Int -> SrcLoc
    mkSrcLoc (FilePath -> FastString
    GHC.mkFastString FilePath
    path) 1 1)
                    (FastString -> Int -> Int -> SrcLoc
    mkSrcLoc (FilePath -> FastString
    GHC.mkFastString FilePath
    path) 1 1)
             in OrmoluException -> IO ([Warn], DynFlags)
    forall e a. Exception e => e -> IO a
    throwIO (SrcSpan -> FilePath -> OrmoluException
    OrmoluParsingFailed SrcSpan
    loc FilePath
    err)
      let useRecordDot :: Bool
    useRecordDot =
            "record-dot-preprocessor" FilePath -> FilePath -> Bool
    forall a. Eq a => a -> a -> Bool
    == DynFlags -> FilePath
    pgm_F DynFlags
    dynFlags
              Bool -> Bool -> Bool
    || (ModuleName -> Bool) -> [ModuleName] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any
                (("RecordDotPreprocessor" FilePath -> FilePath -> Bool
    forall a. Eq a => a -> a -> Bool
    ==) (FilePath -> Bool)
    -> (ModuleName -> FilePath) -> ModuleName -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ModuleName -> FilePath
    moduleNameString)
                (DynFlags -> [ModuleName]
    pluginModNames DynFlags
    dynFlags)
          pStateErrors :: PState -> Maybe (SrcSpan, FilePath)
    pStateErrors = \pstate :: PState
    pstate ->
            let errs :: [ErrMsg]
    errs = Bag ErrMsg -> [ErrMsg]
    forall a. Bag a -> [a]
    bagToList (Bag ErrMsg -> [ErrMsg]) -> Bag ErrMsg -> [ErrMsg]
    forall a b. (a -> b) -> a -> b
    $ PState -> DynFlags -> Bag ErrMsg
    GHC.getErrorMessages PState
    pstate DynFlags
    dynFlags
                fixupErrSpan :: SrcSpan -> SrcSpan
    fixupErrSpan = Int -> SrcSpan -> SrcSpan
    incSpanLine (RegionDeltas -> Int
    regionPrefixLength RegionDeltas
    cfgRegion)
             in case (ErrMsg -> Down SeverityOrd) -> [ErrMsg] -> [ErrMsg]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    L.sortOn (SeverityOrd -> Down SeverityOrd
    forall a. a -> Down a
    Down (SeverityOrd -> Down SeverityOrd)
    -> (ErrMsg -> SeverityOrd) -> ErrMsg -> Down SeverityOrd
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Severity -> SeverityOrd
    SeverityOrd (Severity -> SeverityOrd)
    -> (ErrMsg -> Severity) -> ErrMsg -> SeverityOrd
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ErrMsg -> Severity
    errMsgSeverity) [ErrMsg]
    errs of
                  [] -> Maybe (SrcSpan, FilePath)
    forall a. Maybe a
    Nothing
                  err :: ErrMsg
    err : _ ->
                    -- Show instance returns a short error message
                    (SrcSpan, FilePath) -> Maybe (SrcSpan, FilePath)
    forall a. a -> Maybe a
    Just (SrcSpan -> SrcSpan
    fixupErrSpan (ErrMsg -> SrcSpan
    errMsgSpan ErrMsg
    err), ErrMsg -> FilePath
    forall a. Show a => a -> FilePath
    show ErrMsg
    err)
          r :: Either (SrcSpan, FilePath) ParseResult
    r = case P (Located (HsModule GhcPs))
    -> DynFlags
    -> FilePath
    -> FilePath
    -> ParseResult (Located (HsModule GhcPs))
    forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
    runParser P (Located (HsModule GhcPs))
    GHC.parseModule DynFlags
    dynFlags FilePath
    path FilePath
    input of
            GHC.PFailed pstate :: PState
    pstate ->
              case PState -> Maybe (SrcSpan, FilePath)
    pStateErrors PState
    pstate of
                Just err :: (SrcSpan, FilePath)
    err -> (SrcSpan, FilePath) -> Either (SrcSpan, FilePath) ParseResult
    forall a b. a -> Either a b
    Left (SrcSpan, FilePath)
    err
                Nothing -> FilePath -> Either (SrcSpan, FilePath) ParseResult
    forall a. HasCallStack => FilePath -> a
    error "PFailed does not have an error"
            GHC.POk pstate :: PState
    pstate (L _ hsModule :: HsModule GhcPs
    hsModule) ->
              case PState -> Maybe (SrcSpan, FilePath)
    pStateErrors PState
    pstate of
                -- Some parse errors (pattern/arrow syntax in expr context)
                -- do not cause a parse error, but they are replaced with "_"
                -- by the parser and the modified AST is propagated to the
                -- later stages; but we fail in those cases.
                Just err :: (SrcSpan, FilePath)
    err -> (SrcSpan, FilePath) -> Either (SrcSpan, FilePath) ParseResult
    forall a b. a -> Either a b
    Left (SrcSpan, FilePath)
    err
                Nothing ->
                  let (stackHeader :: Maybe (RealLocated Comment)
    stackHeader, shebangs :: [Shebang]
    shebangs, pragmas :: [([RealLocated Comment], Pragma)]
    pragmas, comments :: CommentStream
    comments) =
                        FilePath
    -> [Located FilePath]
    -> PState
    -> (Maybe (RealLocated Comment), [Shebang],
        [([RealLocated Comment], Pragma)], CommentStream)
    mkCommentStream FilePath
    input [Located FilePath]
    extraComments PState
    pstate
                   in ParseResult -> Either (SrcSpan, FilePath) ParseResult
    forall a b. b -> Either a b
    Right
                        ParseResult :: HsModule GhcPs
    -> Anns
    -> Maybe (RealLocated Comment)
    -> [Shebang]
    -> [([RealLocated Comment], Pragma)]
    -> CommentStream
    -> Bool
    -> Bool
    -> Text
    -> Text
    -> Int
    -> ParseResult
    ParseResult
                          { prParsedSource :: HsModule GhcPs
    prParsedSource = HsModule GhcPs
    hsModule,
                            prAnns :: Anns
    prAnns = PState -> Anns
    mkAnns PState
    pstate,
                            prStackHeader :: Maybe (RealLocated Comment)
    prStackHeader = Maybe (RealLocated Comment)
    stackHeader,
                            prShebangs :: [Shebang]
    prShebangs = [Shebang]
    shebangs,
                            prPragmas :: [([RealLocated Comment], Pragma)]
    prPragmas = [([RealLocated Comment], Pragma)]
    pragmas,
                            prCommentStream :: CommentStream
    prCommentStream = CommentStream
    comments,
                            prUseRecordDot :: Bool
    prUseRecordDot = Bool
    useRecordDot,
                            prImportQualifiedPost :: Bool
    prImportQualifiedPost =
                              Extension -> DynFlags -> Bool
    GHC.xopt Extension
    ImportQualifiedPost DynFlags
    dynFlags,
                            prLiteralPrefix :: Text
    prLiteralPrefix = FilePath -> Text
    T.pack FilePath
    literalPrefix,
                            prLiteralSuffix :: Text
    prLiteralSuffix = FilePath -> Text
    T.pack FilePath
    literalSuffix,
                            prIndent :: Int
    prIndent = Int
    indent
                          }
      ([Warn], Either (SrcSpan, FilePath) ParseResult)
    -> IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Warn]
    warnings, Either (SrcSpan, FilePath) ParseResult
    r)

    -- | Enable all language extensions that we think should be enabled by
    -- default for ease of use.
    setDefaultExts :: DynFlags -> DynFlags
    setDefaultExts :: DynFlags -> DynFlags
    setDefaultExts flags :: DynFlags
    flags = (DynFlags -> Extension -> DynFlags)
    -> DynFlags -> [Extension] -> DynFlags
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    L.foldl' DynFlags -> Extension -> DynFlags
    xopt_set DynFlags
    flags [Extension]
    autoExts
      where
        autoExts :: [Extension]
    autoExts = [Extension]
    allExts [Extension] -> [Extension] -> [Extension]
    forall a. Eq a => [a] -> [a] -> [a]
    L.\\ [Extension]
    manualExts
        allExts :: [Extension]
    allExts = [Extension
    forall a. Bounded a => a
    minBound .. Extension
    forall a. Bounded a => a
    maxBound]

    -- | Extensions that are not enabled automatically and should be activated
    -- by user.
    manualExts :: [Extension]
    manualExts :: [Extension]
    manualExts =
      [ Extension
    Arrows, -- steals proc
        Extension
    Cpp, -- forbidden
        Extension
    BangPatterns, -- makes certain patterns with ! fail
        Extension
    PatternSynonyms, -- steals the pattern keyword
        Extension
    RecursiveDo, -- steals the rec keyword
        Extension
    StaticPointers, -- steals static keyword
        Extension
    TransformListComp, -- steals the group keyword
        Extension
    UnboxedTuples, -- breaks (#) lens operator
        Extension
    MagicHash, -- screws {-# these things #-}
        Extension
    TypeApplications, -- steals (@) operator on some cases
        Extension
    AlternativeLayoutRule,
        Extension
    AlternativeLayoutRuleTransitional,
        Extension
    MonadComprehensions,
        Extension
    UnboxedSums,
        Extension
    UnicodeSyntax, -- gives special meanings to operators like (→)
        Extension
    TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this
        -- apparently interferes with QuasiQuotes in
        -- weird ways
        Extension
    ImportQualifiedPost -- affects how Ormolu renders imports, so the
        -- decision of enabling this style is left to the user
      ]

    -- | Run a 'GHC.P' computation.
    runParser ::
      -- | Computation to run
      GHC.P a ->
      -- | Dynamic flags
      GHC.DynFlags ->
      -- | Module path
      FilePath ->
      -- | Module contents
      String ->
      -- | Parse result
      GHC.ParseResult a
    runParser :: P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
    runParser parser :: P a
    parser flags :: DynFlags
    flags filename :: FilePath
    filename input :: FilePath
    input = P a -> PState -> ParseResult a
    forall a. P a -> PState -> ParseResult a
    GHC.unP P a
    parser PState
    parseState
      where
        location :: RealSrcLoc
    location = FastString -> Int -> Int -> RealSrcLoc
    GHC.mkRealSrcLoc (FilePath -> FastString
    GHC.mkFastString FilePath
    filename) 1 1
        buffer :: StringBuffer
    buffer = FilePath -> StringBuffer
    GHC.stringToStringBuffer FilePath
    input
        parseState :: PState
    parseState = DynFlags -> StringBuffer -> RealSrcLoc -> PState
    GHC.mkPState DynFlags
    flags StringBuffer
    buffer RealSrcLoc
    location

    -- | Wrap GHC's 'Severity' to add 'Ord' instance.
    newtype SeverityOrd = SeverityOrd Severity

    instance Eq SeverityOrd where
      s1 :: SeverityOrd
    s1 == :: SeverityOrd -> SeverityOrd -> Bool
    == s2 :: SeverityOrd
    s2 = SeverityOrd -> SeverityOrd -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare SeverityOrd
    s1 SeverityOrd
    s2 Ordering -> Ordering -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ordering
    EQ

    instance Ord SeverityOrd where
      compare :: SeverityOrd -> SeverityOrd -> Ordering
    compare (SeverityOrd s1 :: Severity
    s1) (SeverityOrd s2 :: Severity
    s2) =
        Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (Severity -> Int
    f Severity
    s1) (Severity -> Int
    f Severity
    s2)
        where
          f :: Severity -> Int
          f :: Severity -> Int
    f SevOutput = 1
          f SevFatal = 2
          f SevInteractive = 3
          f SevDump = 4
          f SevInfo = 5
          f SevWarning = 6
          f SevError = 7

    ----------------------------------------------------------------------------
    -- Helpers taken from HLint

    parsePragmasIntoDynFlags ::
      -- | Pre-set 'DynFlags'
      DynFlags ->
      -- | Extra options (provided by user)
      [Located String] ->
      -- | File name (only for source location annotations)
      FilePath ->
      -- | Input for parser
      String ->
      IO (Either String ([GHC.Warn], DynFlags))
    parsePragmasIntoDynFlags :: DynFlags
    -> [Located FilePath]
    -> FilePath
    -> FilePath
    -> IO (Either FilePath ([Warn], DynFlags))
    parsePragmasIntoDynFlags flags :: DynFlags
    flags extraOpts :: [Located FilePath]
    extraOpts filepath :: FilePath
    filepath str :: FilePath
    str =
      IO (Either FilePath ([Warn], DynFlags))
    -> IO (Either FilePath ([Warn], DynFlags))
    forall (m :: * -> *) b.
    ExceptionMonad m =>
    m (Either FilePath b) -> m (Either FilePath b)
    catchErrors (IO (Either FilePath ([Warn], DynFlags))
     -> IO (Either FilePath ([Warn], DynFlags)))
    -> IO (Either FilePath ([Warn], DynFlags))
    -> IO (Either FilePath ([Warn], DynFlags))
    forall a b. (a -> b) -> a -> b
    $ do
        let opts :: [Located FilePath]
    opts = DynFlags -> StringBuffer -> FilePath -> [Located FilePath]
    GHC.getOptions DynFlags
    flags (FilePath -> StringBuffer
    GHC.stringToStringBuffer FilePath
    str) FilePath
    filepath
        (flags' :: DynFlags
    flags', leftovers :: [Located FilePath]
    leftovers, warnings :: [Warn]
    warnings) <-
          DynFlags
    -> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
    forall (m :: * -> *).
    MonadIO m =>
    DynFlags
    -> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
    parseDynamicFilePragma DynFlags
    flags ([Located FilePath]
    opts [Located FilePath] -> [Located FilePath] -> [Located FilePath]
    forall a. Semigroup a => a -> a -> a
    <> [Located FilePath]
    extraOpts)
        case [Located FilePath] -> Maybe (NonEmpty (Located FilePath))
    forall a. [a] -> Maybe (NonEmpty a)
    NE.nonEmpty [Located FilePath]
    leftovers of
          Nothing -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          Just unrecognizedOpts :: NonEmpty (Located FilePath)
    unrecognizedOpts ->
            OrmoluException -> IO ()
    forall e a. Exception e => e -> IO a
    throwIO (NonEmpty FilePath -> OrmoluException
    OrmoluUnrecognizedOpts (Located FilePath -> FilePath
    forall a. HasSrcSpan a => a -> SrcSpanLess a
    unLoc (Located FilePath -> FilePath)
    -> NonEmpty (Located FilePath) -> NonEmpty FilePath
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> NonEmpty (Located FilePath)
    unrecognizedOpts))
        let flags'' :: DynFlags
    flags'' = DynFlags
    flags' DynFlags -> GeneralFlag -> DynFlags
    `gopt_set` GeneralFlag
    Opt_KeepRawTokenStream
        Either FilePath ([Warn], DynFlags)
    -> IO (Either FilePath ([Warn], DynFlags))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either FilePath ([Warn], DynFlags)
     -> IO (Either FilePath ([Warn], DynFlags)))
    -> Either FilePath ([Warn], DynFlags)
    -> IO (Either FilePath ([Warn], DynFlags))
    forall a b. (a -> b) -> a -> b
    $ ([Warn], DynFlags) -> Either FilePath ([Warn], DynFlags)
    forall a b. b -> Either a b
    Right ([Warn]
    warnings, DynFlags
    flags'')
      where
        catchErrors :: m (Either FilePath b) -> m (Either FilePath b)
    catchErrors act :: m (Either FilePath b)
    act =
          (GhcException -> m (Either FilePath b))
    -> m (Either FilePath b) -> m (Either FilePath b)
    forall (m :: * -> *) a.
    ExceptionMonad m =>
    (GhcException -> m a) -> m a -> m a
    GHC.handleGhcException
            GhcException -> m (Either FilePath b)
    forall (m :: * -> *) a b.
    (Monad m, Show a) =>
    a -> m (Either FilePath b)
    reportErr
            ((SourceError -> m (Either FilePath b))
    -> m (Either FilePath b) -> m (Either FilePath b)
    forall (m :: * -> *) a.
    ExceptionMonad m =>
    (SourceError -> m a) -> m a -> m a
    GHC.handleSourceError SourceError -> m (Either FilePath b)
    forall (m :: * -> *) a b.
    (Monad m, Show a) =>
    a -> m (Either FilePath b)
    reportErr m (Either FilePath b)
    act)
        reportErr :: a -> m (Either FilePath b)
    reportErr e :: a
    e = Either FilePath b -> m (Either FilePath b)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either FilePath b -> m (Either FilePath b))
    -> Either FilePath b -> m (Either FilePath b)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Either FilePath b
    forall a b. a -> Either a b
    Left (a -> FilePath
    forall a. Show a => a -> FilePath
    show a
    e)