{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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.Functor
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.FastString as GHC
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.CmdLine as GHC
import GHC.Driver.Session as GHC
import qualified GHC.Driver.Types as GHC
import GHC.DynFlags (baseDynFlags)
import GHC.LanguageExtensions.Type (Extension (..))
import qualified GHC.Parser as GHC
import qualified GHC.Parser.Header as GHC
import qualified GHC.Parser.Lexer as GHC
import GHC.Types.SrcLoc
import GHC.Unit.Module.Name
import GHC.Utils.Error (Severity (..), errMsgSeverity, errMsgSpan)
import qualified GHC.Utils.Panic as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Parser.Anns
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 ->
  -- | File name (only for source location annotations)
  FilePath ->
  -- | Input for parser
  String ->
  m
    ( [GHC.Warn],
      Either (SrcSpan, String) [SourceSnippet]
    )
parseModule :: Config RegionDeltas
-> FilePath
-> FilePath
-> m ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
parseModule config :: Config RegionDeltas
config@Config {Bool
[DynOption]
ColorMode
RegionDeltas
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDynOptions :: [DynOption]
..} FilePath
path FilePath
rawInput = IO ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
-> m ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
 -> m ([Warn], Either (SrcSpan, FilePath) [SourceSnippet]))
-> IO ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
-> m ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
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 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
  ([Warn]
warnings, 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 ([Warn], DynFlags)
res -> ([Warn], DynFlags) -> IO ([Warn], DynFlags)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn], DynFlags)
res
      Left FilePath
err ->
        let loc :: SrcSpan
loc =
              SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan
                (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
path) Int
1 Int
1)
                (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
path) Int
1 Int
1)
         in OrmoluException -> IO ([Warn], DynFlags)
forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> FilePath -> OrmoluException
OrmoluParsingFailed SrcSpan
loc FilePath
err)
  Either (SrcSpan, FilePath) [SourceSnippet]
snippets <- ExceptT (SrcSpan, FilePath) IO [SourceSnippet]
-> IO (Either (SrcSpan, FilePath) [SourceSnippet])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (SrcSpan, FilePath) IO [SourceSnippet]
 -> IO (Either (SrcSpan, FilePath) [SourceSnippet]))
-> ((Either Text RegionDeltas
     -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
    -> ExceptT (SrcSpan, FilePath) IO [SourceSnippet])
-> (Either Text RegionDeltas
    -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
-> IO (Either (SrcSpan, FilePath) [SourceSnippet])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Text RegionDeltas]
-> (Either Text RegionDeltas
    -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
-> ExceptT (SrcSpan, FilePath) IO [SourceSnippet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (RegionDeltas -> FilePath -> [Either Text RegionDeltas]
preprocess RegionDeltas
cfgRegion FilePath
rawInput) ((Either Text RegionDeltas
  -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
 -> IO (Either (SrcSpan, FilePath) [SourceSnippet]))
-> (Either Text RegionDeltas
    -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
-> IO (Either (SrcSpan, FilePath) [SourceSnippet])
forall a b. (a -> b) -> a -> b
$ \case
    Right RegionDeltas
region ->
      (ParseResult -> SourceSnippet)
-> ExceptT (SrcSpan, FilePath) IO ParseResult
-> ExceptT (SrcSpan, FilePath) IO SourceSnippet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseResult -> SourceSnippet
ParsedSnippet (ExceptT (SrcSpan, FilePath) IO ParseResult
 -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
-> (IO (Either (SrcSpan, FilePath) ParseResult)
    -> ExceptT (SrcSpan, FilePath) IO ParseResult)
-> IO (Either (SrcSpan, FilePath) ParseResult)
-> ExceptT (SrcSpan, FilePath) IO SourceSnippet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either (SrcSpan, FilePath) ParseResult)
-> ExceptT (SrcSpan, FilePath) IO ParseResult
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (SrcSpan, FilePath) ParseResult)
 -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
-> IO (Either (SrcSpan, FilePath) ParseResult)
-> ExceptT (SrcSpan, FilePath) IO SourceSnippet
forall a b. (a -> b) -> a -> b
$
        Config RegionDeltas
-> DynFlags
-> FilePath
-> FilePath
-> IO (Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> DynFlags
-> FilePath
-> FilePath
-> m (Either (SrcSpan, FilePath) ParseResult)
parseModuleSnippet (Config RegionDeltas
config Config RegionDeltas -> RegionDeltas -> Config RegionDeltas
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> RegionDeltas
region) DynFlags
dynFlags FilePath
path FilePath
rawInput
    Left Text
raw -> SourceSnippet -> ExceptT (SrcSpan, FilePath) IO SourceSnippet
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceSnippet -> ExceptT (SrcSpan, FilePath) IO SourceSnippet)
-> SourceSnippet -> ExceptT (SrcSpan, FilePath) IO SourceSnippet
forall a b. (a -> b) -> a -> b
$ Text -> SourceSnippet
RawSnippet Text
raw
  ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
-> IO ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn]
warnings, Either (SrcSpan, FilePath) [SourceSnippet]
snippets)

parseModuleSnippet ::
  MonadIO m =>
  Config RegionDeltas ->
  DynFlags ->
  FilePath ->
  String ->
  m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet :: Config RegionDeltas
-> DynFlags
-> FilePath
-> FilePath
-> m (Either (SrcSpan, FilePath) ParseResult)
parseModuleSnippet Config {Bool
[DynOption]
ColorMode
RegionDeltas
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDynOptions :: [DynOption]
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDynOptions :: forall region. Config region -> [DynOption]
..} DynFlags
dynFlags FilePath
path FilePath
rawInput = IO (Either (SrcSpan, FilePath) ParseResult)
-> m (Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (SrcSpan, FilePath) ParseResult)
 -> m (Either (SrcSpan, FilePath) ParseResult))
-> IO (Either (SrcSpan, FilePath) ParseResult)
-> m (Either (SrcSpan, FilePath) ParseResult)
forall a b. (a -> b) -> a -> b
$ do
  let (FilePath
input, Int
indent) = FilePath -> (FilePath, Int)
removeIndentation (FilePath -> (FilePath, Int))
-> (FilePath -> FilePath) -> FilePath -> (FilePath, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegionDeltas -> FilePath -> FilePath
linesInRegion RegionDeltas
cfgRegion (FilePath -> (FilePath, Int)) -> FilePath -> (FilePath, Int)
forall a b. (a -> b) -> a -> b
$ FilePath
rawInput
  let useRecordDot :: Bool
useRecordDot =
        FilePath
"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
            ((FilePath
"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 ->
        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
              ErrMsg
err : [ErrMsg]
_ ->
                -- 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)
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located HsModule)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located HsModule)
GHC.parseModule DynFlags
dynFlags FilePath
path FilePath
input of
        GHC.PFailed PState
pstate ->
          case PState -> Maybe (SrcSpan, FilePath)
pStateErrors PState
pstate of
            Just (SrcSpan, FilePath)
err -> (SrcSpan, FilePath) -> Either (SrcSpan, FilePath) ParseResult
forall a b. a -> Either a b
Left (SrcSpan, FilePath)
err
            Maybe (SrcSpan, FilePath)
Nothing -> FilePath -> Either (SrcSpan, FilePath) ParseResult
forall a. HasCallStack => FilePath -> a
error FilePath
"PFailed does not have an error"
        GHC.POk PState
pstate (L SrcSpan
_ HsModule
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 (SrcSpan, FilePath)
err -> (SrcSpan, FilePath) -> Either (SrcSpan, FilePath) ParseResult
forall a b. a -> Either a b
Left (SrcSpan, FilePath)
err
            Maybe (SrcSpan, FilePath)
Nothing ->
              let (Maybe (RealLocated Comment)
stackHeader, [([RealLocated Comment], Pragma)]
pragmas, CommentStream
comments) =
                    FilePath
-> PState
-> (Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)],
    CommentStream)
mkCommentStream FilePath
input PState
pstate
               in ParseResult -> Either (SrcSpan, FilePath) ParseResult
forall a b. b -> Either a b
Right
                    ParseResult :: HsModule
-> Anns
-> Maybe (RealLocated Comment)
-> [([RealLocated Comment], Pragma)]
-> CommentStream
-> Bool
-> EnumSet Extension
-> Int
-> ParseResult
ParseResult
                      { prParsedSource :: HsModule
prParsedSource = HsModule
hsModule,
                        prAnns :: Anns
prAnns = PState -> Anns
mkAnns PState
pstate,
                        prStackHeader :: Maybe (RealLocated Comment)
prStackHeader = Maybe (RealLocated Comment)
stackHeader,
                        prPragmas :: [([RealLocated Comment], Pragma)]
prPragmas = [([RealLocated Comment], Pragma)]
pragmas,
                        prCommentStream :: CommentStream
prCommentStream = CommentStream
comments,
                        prUseRecordDot :: Bool
prUseRecordDot = Bool
useRecordDot,
                        prExtensions :: EnumSet Extension
prExtensions = DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags,
                        prIndent :: Int
prIndent = Int
indent
                      }
  Either (SrcSpan, FilePath) ParseResult
-> IO (Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 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
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
  ]

-- | 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 P a
parser DynFlags
flags FilePath
filename 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
mkRealSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
filename) Int
1 Int
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
  SeverityOrd
s1 == :: SeverityOrd -> SeverityOrd -> Bool
== 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 Severity
s1) (SeverityOrd 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 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 FilePath]
-> FilePath
-> FilePath
-> IO (Either FilePath ([Warn], DynFlags))
parsePragmasIntoDynFlags DynFlags
flags [Located FilePath]
extraOpts FilePath
filepath FilePath
str =
  IO (Either FilePath ([Warn], DynFlags))
-> IO (Either FilePath ([Warn], DynFlags))
forall (m :: * -> *) b.
(MonadMask m, MonadIO 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 fileOpts :: [Located FilePath]
fileOpts = DynFlags -> StringBuffer -> FilePath -> [Located FilePath]
GHC.getOptions DynFlags
flags (FilePath -> StringBuffer
GHC.stringToStringBuffer FilePath
str) FilePath
filepath
    (DynFlags
flags', [Located FilePath]
leftovers, [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]
extraOpts [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. Semigroup a => a -> a -> a
<> [Located FilePath]
fileOpts)
    case [Located FilePath] -> Maybe (NonEmpty (Located FilePath))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Located FilePath]
leftovers of
      Maybe (NonEmpty (Located FilePath))
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just NonEmpty (Located FilePath)
unrecognizedOpts ->
        OrmoluException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (NonEmpty FilePath -> OrmoluException
OrmoluUnrecognizedOpts (Located FilePath -> FilePath
forall l e. GenLocated l e -> e
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 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.
MonadCatch 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 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)