{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

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

import Control.Exception
import Control.Monad.Except
import Data.Char (isSpace)
import Data.Functor
import Data.Generics
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Data.Ord (Down (Down))
import GHC.Data.Bag (bagToList)
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.Data.FastString as GHC
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.CmdLine as GHC
import GHC.Driver.Session as GHC
import GHC.DynFlags (baseDynFlags)
import GHC.Hs hiding (UnicodeSyntax)
import GHC.LanguageExtensions.Type (Extension (..))
import qualified GHC.Parser as GHC
import GHC.Parser.Errors.Ppr (pprError)
import qualified GHC.Parser.Header as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Types.SourceError as GHC (handleSourceError)
import GHC.Types.SrcLoc
import GHC.Utils.Error (Severity (..), errMsgSeverity, errMsgSpan)
import qualified GHC.Utils.Panic as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Fixity (LazyFixityMap)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Processing.Common
import Ormolu.Processing.Preprocess
import Ormolu.Utils (incSpanLine)

-- | Parse a complete module from string.
parseModule ::
  MonadIO m =>
  -- | Ormolu configuration
  Config RegionDeltas ->
  -- | Fixity map to include in the resulting 'ParseResult's
  LazyFixityMap ->
  -- | File name (only for source location annotations)
  FilePath ->
  -- | Input for parser
  String ->
  m
    ( [GHC.Warn],
      Either (SrcSpan, String) [SourceSnippet]
    )
parseModule :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> String
-> String
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet])
parseModule config :: Config RegionDeltas
config@Config {Bool
[DynOption]
Set String
FixityMap
PrinterOptsTotal
ColorMode
RegionDeltas
SourceType
cfgPrinterOpts :: forall region. Config region -> PrinterOptsTotal
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgSourceType :: forall region. Config region -> SourceType
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDependencies :: forall region. Config region -> Set String
cfgFixityOverrides :: forall region. Config region -> FixityMap
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgPrinterOpts :: PrinterOptsTotal
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgSourceType :: SourceType
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDependencies :: Set String
cfgFixityOverrides :: FixityMap
cfgDynOptions :: [DynOption]
..} LazyFixityMap
fixityMap String
path String
rawInput = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  -- 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 String]
extraOpts = DynOption -> Located String
dynOptionToLocatedStr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DynOption]
cfgDynOptions
  ([Warn]
warnings, DynFlags
dynFlags) <-
    DynFlags
-> [Located String]
-> String
-> String
-> IO (Either String ([Warn], DynFlags))
parsePragmasIntoDynFlags DynFlags
baseFlags [Located String]
extraOpts String
path String
rawInput forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right ([Warn], DynFlags)
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn], DynFlags)
res
      Left String
err ->
        let loc :: SrcSpan
loc =
              SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan
                (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
GHC.mkFastString String
path) Int
1 Int
1)
                (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
GHC.mkFastString String
path) Int
1 Int
1)
         in forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> String -> OrmoluException
OrmoluParsingFailed SrcSpan
loc String
err)
  let cppEnabled :: Bool
cppEnabled = forall a. Enum a => a -> EnumSet a -> Bool
EnumSet.member Extension
Cpp (DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags)
  Either (SrcSpan, String) [SourceSnippet]
snippets <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Bool -> RegionDeltas -> String -> [Either Text RegionDeltas]
preprocess Bool
cppEnabled RegionDeltas
cfgRegion String
rawInput) forall a b. (a -> b) -> a -> b
$ \case
    Right RegionDeltas
region ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseResult -> SourceSnippet
ParsedSnippet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> DynFlags
-> String
-> String
-> m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet (Config RegionDeltas
config forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> RegionDeltas
region) LazyFixityMap
fixityMap DynFlags
dynFlags String
path String
rawInput
    Left Text
raw -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> SourceSnippet
RawSnippet Text
raw
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn]
warnings, Either (SrcSpan, String) [SourceSnippet]
snippets)

parseModuleSnippet ::
  MonadIO m =>
  Config RegionDeltas ->
  LazyFixityMap ->
  DynFlags ->
  FilePath ->
  String ->
  m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> DynFlags
-> String
-> String
-> m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet Config {Bool
[DynOption]
Set String
FixityMap
PrinterOptsTotal
ColorMode
RegionDeltas
SourceType
cfgPrinterOpts :: PrinterOptsTotal
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgSourceType :: SourceType
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDependencies :: Set String
cfgFixityOverrides :: FixityMap
cfgDynOptions :: [DynOption]
cfgPrinterOpts :: forall region. Config region -> PrinterOptsTotal
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgSourceType :: forall region. Config region -> SourceType
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDependencies :: forall region. Config region -> Set String
cfgFixityOverrides :: forall region. Config region -> FixityMap
cfgDynOptions :: forall region. Config region -> [DynOption]
..} LazyFixityMap
fixityMap DynFlags
dynFlags String
path String
rawInput = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  let (String
input, Int
indent) = String -> (String, Int)
removeIndentation forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegionDeltas -> String -> String
linesInRegion RegionDeltas
cfgRegion forall a b. (a -> b) -> a -> b
$ String
rawInput
  let pStateErrors :: PState -> Maybe (SrcSpan, String)
pStateErrors PState
pstate =
        let errs :: [MsgEnvelope DecoratedSDoc]
errs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bag a -> [a]
bagToList forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
GHC.getErrorMessages PState
pstate
            fixupErrSpan :: SrcSpan -> SrcSpan
fixupErrSpan = Int -> SrcSpan -> SrcSpan
incSpanLine (RegionDeltas -> Int
regionPrefixLength RegionDeltas
cfgRegion)
         in case forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. Severity -> SeverityOrd
SeverityOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. MsgEnvelope e -> Severity
errMsgSeverity) [MsgEnvelope DecoratedSDoc]
errs of
              [] -> forall a. Maybe a
Nothing
              MsgEnvelope DecoratedSDoc
err : [MsgEnvelope DecoratedSDoc]
_ ->
                -- Show instance returns a short error message
                forall a. a -> Maybe a
Just (SrcSpan -> SrcSpan
fixupErrSpan (forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope DecoratedSDoc
err), forall a. Show a => a -> String
show MsgEnvelope DecoratedSDoc
err)
      parser :: P (Located HsModule)
parser = case SourceType
cfgSourceType of
        SourceType
ModuleSource -> P (Located HsModule)
GHC.parseModule
        SourceType
SignatureSource -> P (Located HsModule)
GHC.parseSignature
      r :: Either (SrcSpan, String) ParseResult
r = case forall a. P a -> DynFlags -> String -> String -> ParseResult a
runParser P (Located HsModule)
parser DynFlags
dynFlags String
path String
input of
        GHC.PFailed PState
pstate ->
          case PState -> Maybe (SrcSpan, String)
pStateErrors PState
pstate of
            Just (SrcSpan, String)
err -> forall a b. a -> Either a b
Left (SrcSpan, String)
err
            Maybe (SrcSpan, String)
Nothing -> forall a. HasCallStack => String -> a
error String
"PFailed does not have an error"
        GHC.POk PState
pstate (L SrcSpan
_ (HsModule -> HsModule
normalizeModule -> HsModule
hsModule)) ->
          case PState -> Maybe (SrcSpan, String)
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 (SrcSpan, String)
err -> forall a b. a -> Either a b
Left (SrcSpan, String)
err
            Maybe (SrcSpan, String)
Nothing ->
              let (Maybe (RealLocated Comment)
stackHeader, [([RealLocated Comment], Pragma)]
pragmas, CommentStream
comments) =
                    String
-> HsModule
-> (Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)],
    CommentStream)
mkCommentStream String
input HsModule
hsModule
               in forall a b. b -> Either a b
Right
                    ParseResult
                      { prParsedSource :: HsModule
prParsedSource = HsModule
hsModule,
                        prSourceType :: SourceType
prSourceType = SourceType
cfgSourceType,
                        prStackHeader :: Maybe (RealLocated Comment)
prStackHeader = Maybe (RealLocated Comment)
stackHeader,
                        prPragmas :: [([RealLocated Comment], Pragma)]
prPragmas = [([RealLocated Comment], Pragma)]
pragmas,
                        prCommentStream :: CommentStream
prCommentStream = CommentStream
comments,
                        prExtensions :: EnumSet Extension
prExtensions = DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags,
                        prFixityOverrides :: FixityMap
prFixityOverrides = FixityMap
cfgFixityOverrides,
                        prFixityMap :: LazyFixityMap
prFixityMap = LazyFixityMap
fixityMap,
                        prIndent :: Int
prIndent = Int
indent
                      }
  forall (m :: * -> *) a. Monad m => a -> m a
return Either (SrcSpan, String) ParseResult
r

-- | Normalize a 'HsModule' by sorting its export lists, dropping
-- blank comments, etc.
normalizeModule :: HsModule -> HsModule
normalizeModule :: HsModule -> HsModule
normalizeModule HsModule
hsmod =
  (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere
    (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
dropBlankTypeHaddocks)
    HsModule
hsmod
      { hsmodImports :: [LImportDecl GhcPs]
hsmodImports =
          HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
hsmod,
        hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls =
          forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p}. HsDecl p -> Bool
isBlankDocD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) (HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
hsmod),
        hsmodHaddockModHeader :: Maybe LHsDocString
hsmodHaddockModHeader =
          forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> Bool
isBlankDocString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) (HsModule -> Maybe LHsDocString
hsmodHaddockModHeader HsModule
hsmod),
        hsmodExports :: Maybe (LocatedL [LIE GhcPs])
hsmodExports =
          (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {pass}. IE pass -> Bool
isBlankDocIE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)) (HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodExports HsModule
hsmod)
      }
  where
    isBlankDocString :: HsDocString -> Bool
isBlankDocString = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> String
unpackHDS
    isBlankDocD :: HsDecl p -> Bool
isBlankDocD = \case
      DocD XDocD p
_ DocDecl
s -> HsDocString -> Bool
isBlankDocString forall a b. (a -> b) -> a -> b
$ DocDecl -> HsDocString
docDeclDoc DocDecl
s
      HsDecl p
_ -> Bool
False
    isBlankDocIE :: IE pass -> Bool
isBlankDocIE = \case
      IEGroup XIEGroup pass
_ Int
_ HsDocString
s -> HsDocString -> Bool
isBlankDocString HsDocString
s
      IEDoc XIEDoc pass
_ HsDocString
s -> HsDocString -> Bool
isBlankDocString HsDocString
s
      IE pass
_ -> Bool
False

    dropBlankTypeHaddocks :: LHsType GhcPs -> LHsType GhcPs
dropBlankTypeHaddocks = \case
      L SrcSpanAnnA
_ (HsDocTy XDocTy GhcPs
_ LHsType GhcPs
ty (L SrcSpan
_ HsDocString
ds)) :: LHsType GhcPs
        | HsDocString -> Bool
isBlankDocString HsDocString
ds -> LHsType GhcPs
ty
      LHsType GhcPs
a -> LHsType GhcPs
a

-- | Enable all language extensions that we think should be enabled by
-- default for ease of use.
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts DynFlags
flags = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' DynFlags -> Extension -> DynFlags
xopt_set (DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
flags (forall a. a -> Maybe a
Just Language
Haskell2010)) [Extension]
autoExts
  where
    autoExts :: [Extension]
autoExts = [Extension]
allExts forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Extension]
manualExts
    allExts :: [Extension]
allExts = [forall a. Bounded a => a
minBound .. 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
AlternativeLayoutRule,
    Extension
AlternativeLayoutRuleTransitional,
    Extension
MonadComprehensions,
    Extension
UnboxedSums,
    Extension
UnicodeSyntax, -- gives special meanings to operators like (→)
    Extension
TemplateHaskell, -- changes how $foo is parsed
    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
    Extension
NegativeLiterals, -- with this, `- 1` and `-1` have differing AST
    Extension
LexicalNegation, -- implies NegativeLiterals
    Extension
LinearTypes, -- steals the (%) type operator in some cases
    Extension
OverloadedRecordDot, -- f.g parses differently
    Extension
OverloadedRecordUpdate -- qualified fields are not supported
  ]

-- | 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 :: forall a. P a -> DynFlags -> String -> String -> ParseResult a
runParser P a
parser DynFlags
flags String
filename String
input = forall a. P a -> PState -> ParseResult a
GHC.unP P a
parser PState
parseState
  where
    location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
GHC.mkFastString String
filename) Int
1 Int
1
    buffer :: StringBuffer
buffer = String -> StringBuffer
GHC.stringToStringBuffer String
input
    parseState :: PState
parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
GHC.initParserState (DynFlags -> ParserOpts
opts DynFlags
flags) StringBuffer
buffer RealSrcLoc
location
    opts :: DynFlags -> ParserOpts
opts =
      EnumSet WarningFlag
-> EnumSet Extension -> Bool -> Bool -> Bool -> Bool -> ParserOpts
GHC.mkParserOpts
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> EnumSet WarningFlag
GHC.warningFlags
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DynFlags -> EnumSet Extension
GHC.extensionFlags
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DynFlags -> Bool
GHC.safeImportsOn
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GeneralFlag -> DynFlags -> Bool
GHC.gopt GeneralFlag
GHC.Opt_Haddock
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GeneralFlag -> DynFlags -> Bool
GHC.gopt GeneralFlag
GHC.Opt_KeepRawTokenStream
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b. a -> b -> a
const Bool
True

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

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

instance Ord SeverityOrd where
  compare :: SeverityOrd -> SeverityOrd -> Ordering
compare (SeverityOrd Severity
s1) (SeverityOrd Severity
s2) =
    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 Severity
SevOutput = Int
1
      f Severity
SevFatal = Int
2
      f Severity
SevInteractive = Int
3
      f Severity
SevDump = Int
4
      f Severity
SevInfo = Int
5
      f Severity
SevWarning = Int
6
      f Severity
SevError = Int
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 String]
-> String
-> String
-> IO (Either String ([Warn], DynFlags))
parsePragmasIntoDynFlags DynFlags
flags [Located String]
extraOpts String
filepath String
str =
  forall {m :: * -> *} {b}.
(MonadMask m, MonadIO m) =>
m (Either String b) -> m (Either String b)
catchErrors forall a b. (a -> b) -> a -> b
$ do
    let fileOpts :: [Located String]
fileOpts = DynFlags -> StringBuffer -> String -> [Located String]
GHC.getOptions DynFlags
flags (String -> StringBuffer
GHC.stringToStringBuffer String
str) String
filepath
    (DynFlags
flags', [Located String]
leftovers, [Warn]
warnings) <-
      forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
flags ([Located String]
extraOpts forall a. Semigroup a => a -> a -> a
<> [Located String]
fileOpts)
    case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Located String]
leftovers of
      Maybe (NonEmpty (Located String))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just NonEmpty (Located String)
unrecognizedOpts ->
        forall e a. Exception e => e -> IO a
throwIO (NonEmpty String -> OrmoluException
OrmoluUnrecognizedOpts (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Located String)
unrecognizedOpts))
    let flags'' :: DynFlags
flags'' = DynFlags
flags' DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ([Warn]
warnings, DynFlags
flags'')
  where
    catchErrors :: m (Either String b) -> m (Either String b)
catchErrors m (Either String b)
act =
      forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
GHC.handleGhcException
        forall {m :: * -> *} {a} {b}.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr
        (forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError forall {m :: * -> *} {a} {b}.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr m (Either String b)
act)
    reportErr :: a -> m (Either String b)
reportErr a
e = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show a
e)