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

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

import Control.Exception
import Control.Monad
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.IO.Class
import Data.Char (isSpace)
import Data.Functor
import Data.Generics hiding (orElse)
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import GHC.Builtin.Names (mAIN_NAME)
import GHC.Data.Bag (bagToList)
import GHC.Data.EnumSet qualified as EnumSet
import GHC.Data.FastString qualified as GHC
import GHC.Data.Maybe (orElse)
import GHC.Data.StringBuffer (StringBuffer)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Errors.Types qualified as GHC
import GHC.Driver.Session as GHC
import GHC.DynFlags (baseDynFlags)
import GHC.Hs hiding (UnicodeSyntax)
import GHC.LanguageExtensions.Type (Extension (..))
import GHC.Parser qualified as GHC
import GHC.Parser.Annotation qualified as GHC
import GHC.Parser.Header qualified as GHC
import GHC.Parser.Lexer qualified as GHC
import GHC.Types.Error qualified as GHC
import GHC.Types.SourceError qualified as GHC
import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Utils.Exception (ExceptionMonad)
import GHC.Utils.Panic qualified as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Fixity hiding (packageFixityMap)
import Ormolu.Fixity.Imports (applyModuleReexports, extractFixityImports)
import Ormolu.Imports (normalizeImports)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Processing.Common
import Ormolu.Processing.Cpp (eraseCppLines)
import Ormolu.Processing.Preprocess
import Ormolu.Utils (incSpanLine, showOutputable, textToStringBuffer)

-- | Parse a complete module from 'Text'.
parseModule ::
  (MonadIO m) =>
  -- | Ormolu configuration
  Config RegionDeltas ->
  -- | Package fixity map
  PackageFixityMap ->
  -- | File name (only for source location annotations)
  FilePath ->
  -- | Input for parser
  Text ->
  m
    ( GHC.DriverMessages,
      Either (SrcSpan, String) [SourceSnippet]
    )
parseModule :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> PackageFixityMap
-> String
-> Text
-> m (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
parseModule config :: Config RegionDeltas
config@Config {Bool
[DynOption]
Set PackageName
ColorMode
ModuleReexports
FixityOverrides
RegionDeltas
SourceType
cfgDynOptions :: [DynOption]
cfgFixityOverrides :: FixityOverrides
cfgModuleReexports :: ModuleReexports
cfgDependencies :: Set PackageName
cfgUnsafe :: Bool
cfgDebug :: Bool
cfgCheckIdempotence :: Bool
cfgSourceType :: SourceType
cfgColorMode :: ColorMode
cfgRegion :: RegionDeltas
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgFixityOverrides :: forall region. Config region -> FixityOverrides
cfgModuleReexports :: forall region. Config region -> ModuleReexports
cfgDependencies :: forall region. Config region -> Set PackageName
cfgUnsafe :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgSourceType :: forall region. Config region -> SourceType
cfgColorMode :: forall region. Config region -> ColorMode
cfgRegion :: forall region. Config region -> region
..} PackageFixityMap
packageFixityMap String
path Text
rawInput = IO (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
-> m (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
 -> m (DriverMessages, Either (SrcSpan, String) [SourceSnippet]))
-> IO (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
-> m (DriverMessages, Either (SrcSpan, String) [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 String]
extraOpts = DynOption -> Located String
dynOptionToLocatedStr (DynOption -> Located String) -> [DynOption] -> [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DynOption]
cfgDynOptions
      rawInputStringBuffer :: StringBuffer
rawInputStringBuffer = Text -> StringBuffer
textToStringBuffer (Text -> Text
eraseCppLines Text
rawInput)
      beginningLoc :: SrcSpan
beginningLoc =
        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)
  (DriverMessages
warnings, DynFlags
dynFlags) <-
    DynFlags
-> [Located String]
-> String
-> StringBuffer
-> IO (Either String (DriverMessages, DynFlags))
parsePragmasIntoDynFlags DynFlags
baseFlags [Located String]
extraOpts String
path StringBuffer
rawInputStringBuffer IO (Either String (DriverMessages, DynFlags))
-> (Either String (DriverMessages, DynFlags)
    -> IO (DriverMessages, DynFlags))
-> IO (DriverMessages, DynFlags)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right (DriverMessages, DynFlags)
res -> (DriverMessages, DynFlags) -> IO (DriverMessages, DynFlags)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DriverMessages, DynFlags)
res
      Left String
err -> OrmoluException -> IO (DriverMessages, DynFlags)
forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> String -> OrmoluException
OrmoluParsingFailed SrcSpan
beginningLoc String
err)
  let cppEnabled :: Bool
cppEnabled = Extension -> EnumSet Extension -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
EnumSet.member Extension
Cpp (DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags)
      implicitPrelude :: Bool
implicitPrelude = Extension -> EnumSet Extension -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
EnumSet.member Extension
ImplicitPrelude (DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags)
  [FixityImport]
fixityImports <-
    DynFlags
-> Bool
-> String
-> StringBuffer
-> IO (Either String [LImportDecl GhcPs])
parseImports DynFlags
dynFlags Bool
implicitPrelude String
path StringBuffer
rawInputStringBuffer IO (Either String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> (Either String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
    -> IO [FixityImport])
-> IO [FixityImport]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
res ->
        [FixityImport] -> IO [FixityImport]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleReexports -> [FixityImport] -> [FixityImport]
applyModuleReexports ModuleReexports
cfgModuleReexports ([LImportDecl GhcPs] -> [FixityImport]
extractFixityImports [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
res))
      Left String
err ->
        OrmoluException -> IO [FixityImport]
forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> String -> OrmoluException
OrmoluParsingFailed SrcSpan
beginningLoc String
err)
  let modFixityMap :: ModuleFixityMap
modFixityMap =
        FixityOverrides -> ModuleFixityMap -> ModuleFixityMap
applyFixityOverrides
          FixityOverrides
cfgFixityOverrides
          (PackageFixityMap -> [FixityImport] -> ModuleFixityMap
moduleFixityMap PackageFixityMap
packageFixityMap [FixityImport]
fixityImports)
  Either (SrcSpan, String) [SourceSnippet]
snippets <- ExceptT (SrcSpan, String) IO [SourceSnippet]
-> IO (Either (SrcSpan, String) [SourceSnippet])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (SrcSpan, String) IO [SourceSnippet]
 -> IO (Either (SrcSpan, String) [SourceSnippet]))
-> ((Either Text RegionDeltas
     -> ExceptT (SrcSpan, String) IO SourceSnippet)
    -> ExceptT (SrcSpan, String) IO [SourceSnippet])
-> (Either Text RegionDeltas
    -> ExceptT (SrcSpan, String) IO SourceSnippet)
-> IO (Either (SrcSpan, String) [SourceSnippet])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Text RegionDeltas]
-> (Either Text RegionDeltas
    -> ExceptT (SrcSpan, String) IO SourceSnippet)
-> ExceptT (SrcSpan, String) IO [SourceSnippet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Bool -> RegionDeltas -> Text -> [Either Text RegionDeltas]
preprocess Bool
cppEnabled RegionDeltas
cfgRegion Text
rawInput) ((Either Text RegionDeltas
  -> ExceptT (SrcSpan, String) IO SourceSnippet)
 -> IO (Either (SrcSpan, String) [SourceSnippet]))
-> (Either Text RegionDeltas
    -> ExceptT (SrcSpan, String) IO SourceSnippet)
-> IO (Either (SrcSpan, String) [SourceSnippet])
forall a b. (a -> b) -> a -> b
$ \case
    Right RegionDeltas
region ->
      (ParseResult -> SourceSnippet)
-> ExceptT (SrcSpan, String) IO ParseResult
-> ExceptT (SrcSpan, String) IO SourceSnippet
forall a b.
(a -> b)
-> ExceptT (SrcSpan, String) IO a -> ExceptT (SrcSpan, String) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseResult -> SourceSnippet
ParsedSnippet (ExceptT (SrcSpan, String) IO ParseResult
 -> ExceptT (SrcSpan, String) IO SourceSnippet)
-> (IO (Either (SrcSpan, String) ParseResult)
    -> ExceptT (SrcSpan, String) IO ParseResult)
-> IO (Either (SrcSpan, String) ParseResult)
-> ExceptT (SrcSpan, String) IO SourceSnippet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either (SrcSpan, String) ParseResult)
-> ExceptT (SrcSpan, String) IO ParseResult
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (SrcSpan, String) ParseResult)
 -> ExceptT (SrcSpan, String) IO SourceSnippet)
-> IO (Either (SrcSpan, String) ParseResult)
-> ExceptT (SrcSpan, String) IO SourceSnippet
forall a b. (a -> b) -> a -> b
$
        Config RegionDeltas
-> ModuleFixityMap
-> DynFlags
-> String
-> Text
-> IO (Either (SrcSpan, String) ParseResult)
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> ModuleFixityMap
-> DynFlags
-> String
-> Text
-> m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet (Config RegionDeltas
config Config RegionDeltas -> RegionDeltas -> Config RegionDeltas
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> RegionDeltas
region) ModuleFixityMap
modFixityMap DynFlags
dynFlags String
path Text
rawInput
    Left Text
raw -> SourceSnippet -> ExceptT (SrcSpan, String) IO SourceSnippet
forall a. a -> ExceptT (SrcSpan, String) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceSnippet -> ExceptT (SrcSpan, String) IO SourceSnippet)
-> SourceSnippet -> ExceptT (SrcSpan, String) IO SourceSnippet
forall a b. (a -> b) -> a -> b
$ Text -> SourceSnippet
RawSnippet Text
raw
  (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
-> IO (DriverMessages, Either (SrcSpan, String) [SourceSnippet])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DriverMessages
warnings, Either (SrcSpan, String) [SourceSnippet]
snippets)

parseModuleSnippet ::
  (MonadIO m) =>
  Config RegionDeltas ->
  ModuleFixityMap ->
  DynFlags ->
  FilePath ->
  Text ->
  m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> ModuleFixityMap
-> DynFlags
-> String
-> Text
-> m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet Config {Bool
[DynOption]
Set PackageName
ColorMode
ModuleReexports
FixityOverrides
RegionDeltas
SourceType
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgFixityOverrides :: forall region. Config region -> FixityOverrides
cfgModuleReexports :: forall region. Config region -> ModuleReexports
cfgDependencies :: forall region. Config region -> Set PackageName
cfgUnsafe :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgSourceType :: forall region. Config region -> SourceType
cfgColorMode :: forall region. Config region -> ColorMode
cfgRegion :: forall region. Config region -> region
cfgDynOptions :: [DynOption]
cfgFixityOverrides :: FixityOverrides
cfgModuleReexports :: ModuleReexports
cfgDependencies :: Set PackageName
cfgUnsafe :: Bool
cfgDebug :: Bool
cfgCheckIdempotence :: Bool
cfgSourceType :: SourceType
cfgColorMode :: ColorMode
cfgRegion :: RegionDeltas
..} ModuleFixityMap
modFixityMap DynFlags
dynFlags String
path Text
rawInput = IO (Either (SrcSpan, String) ParseResult)
-> m (Either (SrcSpan, String) ParseResult)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (SrcSpan, String) ParseResult)
 -> m (Either (SrcSpan, String) ParseResult))
-> IO (Either (SrcSpan, String) ParseResult)
-> m (Either (SrcSpan, String) ParseResult)
forall a b. (a -> b) -> a -> b
$ do
  let (Text
input, Int
indent) = Text -> (Text, Int)
removeIndentation (Text -> (Text, Int)) -> (Text -> Text) -> Text -> (Text, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegionDeltas -> Text -> Text
linesInRegion RegionDeltas
cfgRegion (Text -> (Text, Int)) -> Text -> (Text, Int)
forall a b. (a -> b) -> a -> b
$ Text
rawInput
  let pStateErrors :: PState -> Maybe (SrcSpan, String)
pStateErrors PState
pstate =
        let errs :: [MsgEnvelope PsMessage]
errs = Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage]
forall a. Bag a -> [a]
bagToList (Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage])
-> (Messages PsMessage -> Bag (MsgEnvelope PsMessage))
-> Messages PsMessage
-> [MsgEnvelope PsMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
GHC.getMessages (Messages PsMessage -> [MsgEnvelope PsMessage])
-> Messages PsMessage -> [MsgEnvelope PsMessage]
forall a b. (a -> b) -> a -> b
$ PState -> Messages PsMessage
GHC.getPsErrorMessages PState
pstate
            fixupErrSpan :: SrcSpan -> SrcSpan
fixupErrSpan = Int -> SrcSpan -> SrcSpan
incSpanLine (RegionDeltas -> Int
regionPrefixLength RegionDeltas
cfgRegion)
            rateSeverity :: Severity -> Int
rateSeverity = \case
              Severity
SevError -> Int
1 :: Int
              Severity
SevWarning -> Int
2
              Severity
SevIgnore -> Int
3
            showErr :: MsgEnvelope a -> String
showErr (MsgEnvelope a -> a
forall e. MsgEnvelope e -> e
errMsgDiagnostic -> a
err) = String
codeMsg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
              where
                codeMsg :: String
codeMsg = case a -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
err of
                  Just DiagnosticCode
code -> String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DiagnosticCode -> String
forall o. Outputable o => o -> String
showOutputable DiagnosticCode
code String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
                  Maybe DiagnosticCode
Nothing -> String
""
                msg :: String
msg =
                  SDoc -> String
forall o. Outputable o => o -> String
showOutputable
                    (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoratedSDoc -> SDoc
formatBulleted
                    (DecoratedSDoc -> SDoc) -> (a -> DecoratedSDoc) -> a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage NoDiagnosticOpts
DiagnosticOpts a
GHC.NoDiagnosticOpts
                    (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
err
         in case (MsgEnvelope PsMessage -> Int)
-> [MsgEnvelope PsMessage] -> [MsgEnvelope PsMessage]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Severity -> Int
rateSeverity (Severity -> Int)
-> (MsgEnvelope PsMessage -> Severity)
-> MsgEnvelope PsMessage
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope PsMessage -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity) [MsgEnvelope PsMessage]
errs of
              [] -> Maybe (SrcSpan, String)
forall a. Maybe a
Nothing
              MsgEnvelope PsMessage
err : [MsgEnvelope PsMessage]
_ ->
                (SrcSpan, String) -> Maybe (SrcSpan, String)
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpan
fixupErrSpan (MsgEnvelope PsMessage -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope PsMessage
err), MsgEnvelope PsMessage -> String
forall {a}.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a) =>
MsgEnvelope a -> String
showErr MsgEnvelope PsMessage
err)
      parser :: P (Located (HsModule GhcPs))
parser = case SourceType
cfgSourceType of
        SourceType
ModuleSource -> P (Located (HsModule GhcPs))
GHC.parseModule
        SourceType
SignatureSource -> P (Located (HsModule GhcPs))
GHC.parseSignature
      r :: Either (SrcSpan, String) ParseResult
r = case P (Located (HsModule GhcPs))
-> DynFlags
-> String
-> Text
-> ParseResult (Located (HsModule GhcPs))
forall a. P a -> DynFlags -> String -> Text -> ParseResult a
runParser P (Located (HsModule GhcPs))
parser DynFlags
dynFlags String
path Text
input of
        GHC.PFailed PState
pstate ->
          case PState -> Maybe (SrcSpan, String)
pStateErrors PState
pstate of
            Just (SrcSpan, String)
err -> (SrcSpan, String) -> Either (SrcSpan, String) ParseResult
forall a b. a -> Either a b
Left (SrcSpan, String)
err
            Maybe (SrcSpan, String)
Nothing -> String -> Either (SrcSpan, String) ParseResult
forall a. HasCallStack => String -> a
error String
"PFailed does not have an error"
        GHC.POk PState
pstate (L SrcSpan
_ (HsModule GhcPs -> HsModule GhcPs
normalizeModule -> HsModule GhcPs
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 -> (SrcSpan, String) -> Either (SrcSpan, String) ParseResult
forall a b. a -> Either a b
Left (SrcSpan, String)
err
            Maybe (SrcSpan, String)
Nothing ->
              let (Maybe LComment
stackHeader, [([LComment], Pragma)]
pragmas, CommentStream
comments) =
                    Text
-> HsModule GhcPs
-> (Maybe LComment, [([LComment], Pragma)], CommentStream)
mkCommentStream Text
input HsModule GhcPs
hsModule
               in ParseResult -> Either (SrcSpan, String) ParseResult
forall a b. b -> Either a b
Right
                    ParseResult
                      { prParsedSource :: HsModule GhcPs
prParsedSource = HsModule GhcPs
hsModule,
                        prSourceType :: SourceType
prSourceType = SourceType
cfgSourceType,
                        prStackHeader :: Maybe LComment
prStackHeader = Maybe LComment
stackHeader,
                        prPragmas :: [([LComment], Pragma)]
prPragmas = [([LComment], Pragma)]
pragmas,
                        prCommentStream :: CommentStream
prCommentStream = CommentStream
comments,
                        prExtensions :: EnumSet Extension
prExtensions = DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags,
                        prModuleFixityMap :: ModuleFixityMap
prModuleFixityMap = ModuleFixityMap
modFixityMap,
                        prIndent :: Int
prIndent = Int
indent
                      }
  Either (SrcSpan, String) ParseResult
-> IO (Either (SrcSpan, String) ParseResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either (SrcSpan, String) ParseResult
r

-- | Normalize a 'HsModule' by sorting its import\/export lists, dropping
-- blank comments, etc.
normalizeModule :: HsModule GhcPs -> HsModule GhcPs
normalizeModule :: HsModule GhcPs -> HsModule GhcPs
normalizeModule HsModule GhcPs
hsmod =
  (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere
    ((GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
dropBlankTypeHaddocks (a -> a) -> (ConDecl GhcPs -> ConDecl GhcPs) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` ConDecl GhcPs -> ConDecl GhcPs
dropBlankDataDeclHaddocks (a -> a)
-> (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
    -> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> a
-> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` LHsContext GhcPs -> LHsContext GhcPs
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
patchContext)
    HsModule GhcPs
hsmod
      { hsmodImports =
          normalizeImports (hsmodImports hsmod),
        hsmodDecls =
          filter (not . isBlankDocD . unLoc) (hsmodDecls hsmod),
        hsmodExt =
          (hsmodExt hsmod)
            { hsmodHaddockModHeader =
                mfilter (not . isBlankDocString) (hsmodHaddockModHeader (hsmodExt hsmod))
            },
        hsmodExports =
          (fmap . fmap) (filter (not . isBlankDocIE . unLoc)) (hsmodExports hsmod)
      }
  where
    isBlankDocString :: GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (String -> Bool)
-> (GenLocated l (WithHsDocIdentifiers HsDocString pass) -> String)
-> GenLocated l (WithHsDocIdentifiers HsDocString pass)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> String
renderHsDocString (HsDocString -> String)
-> (GenLocated l (WithHsDocIdentifiers HsDocString pass)
    -> HsDocString)
-> GenLocated l (WithHsDocIdentifiers HsDocString pass)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithHsDocIdentifiers HsDocString pass -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers HsDocString pass -> HsDocString)
-> (GenLocated l (WithHsDocIdentifiers HsDocString pass)
    -> WithHsDocIdentifiers HsDocString pass)
-> GenLocated l (WithHsDocIdentifiers HsDocString pass)
-> HsDocString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated l (WithHsDocIdentifiers HsDocString pass)
-> WithHsDocIdentifiers HsDocString pass
forall l e. GenLocated l e -> e
unLoc
    isBlankDocD :: HsDecl pass -> Bool
isBlankDocD = \case
      DocD XDocD pass
_ DocDecl pass
s -> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString pass) -> Bool
forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString pass)
 -> Bool)
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString pass)
-> Bool
forall a b. (a -> b) -> a -> b
$ DocDecl pass
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString pass)
forall pass. DocDecl pass -> LHsDoc pass
docDeclDoc DocDecl pass
s
      HsDecl pass
_ -> Bool
False
    isBlankDocIE :: IE pass -> Bool
isBlankDocIE = \case
      IEGroup XIEGroup pass
_ Int
_ LHsDoc pass
s -> LHsDoc pass -> Bool
forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString LHsDoc pass
s
      IEDoc XIEDoc pass
_ LHsDoc pass
s -> LHsDoc pass -> Bool
forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString LHsDoc pass
s
      IE pass
_ -> Bool
False
    dropBlankTypeHaddocks :: LHsType GhcPs -> LHsType GhcPs
dropBlankTypeHaddocks = \case
      L SrcSpanAnnA
_ (HsDocTy XDocTy GhcPs
_ LHsType GhcPs
ty LHsDoc GhcPs
s) :: LHsType GhcPs
        | LHsDoc GhcPs -> Bool
forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString LHsDoc GhcPs
s -> LHsType GhcPs
ty
      LHsType GhcPs
a -> LHsType GhcPs
a
    dropBlankDataDeclHaddocks :: ConDecl GhcPs -> ConDecl GhcPs
dropBlankDataDeclHaddocks = \case
      ConDeclGADT {con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_doc = Just LHsDoc GhcPs
s, Maybe (LHsContext GhcPs)
NonEmpty (LIdP GhcPs)
XConDeclGADT GhcPs
LHsUniToken "::" "\8759" GhcPs
LHsType GhcPs
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
HsConDeclGADTDetails GhcPs
con_g_ext :: XConDeclGADT GhcPs
con_names :: NonEmpty (LIdP GhcPs)
con_dcolon :: LHsUniToken "::" "\8759" GhcPs
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_g_args :: HsConDeclGADTDetails GhcPs
con_res_ty :: LHsType GhcPs
con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass
con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_dcolon :: forall pass. ConDecl pass -> LHsUniToken "::" "\8759" pass
con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
..} :: ConDecl GhcPs
        | LHsDoc GhcPs -> Bool
forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString LHsDoc GhcPs
s -> ConDeclGADT {con_doc :: Maybe (LHsDoc GhcPs)
con_doc = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing, Maybe (LHsContext GhcPs)
NonEmpty (LIdP GhcPs)
XConDeclGADT GhcPs
LHsUniToken "::" "\8759" GhcPs
LHsType GhcPs
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
HsConDeclGADTDetails GhcPs
con_g_ext :: XConDeclGADT GhcPs
con_names :: NonEmpty (LIdP GhcPs)
con_dcolon :: LHsUniToken "::" "\8759" GhcPs
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_g_args :: HsConDeclGADTDetails GhcPs
con_res_ty :: LHsType GhcPs
con_g_ext :: XConDeclGADT GhcPs
con_names :: NonEmpty (LIdP GhcPs)
con_dcolon :: LHsUniToken "::" "\8759" GhcPs
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_g_args :: HsConDeclGADTDetails GhcPs
con_res_ty :: LHsType GhcPs
..}
      ConDeclH98 {con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_doc = Just LHsDoc GhcPs
s, Bool
[LHsTyVarBndr Specificity GhcPs]
Maybe (LHsContext GhcPs)
XConDeclH98 GhcPs
LIdP GhcPs
HsConDeclH98Details GhcPs
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_ext :: XConDeclH98 GhcPs
con_name :: LIdP GhcPs
con_forall :: Bool
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_args :: HsConDeclH98Details GhcPs
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
..} :: ConDecl GhcPs
        | LHsDoc GhcPs -> Bool
forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString LHsDoc GhcPs
s -> ConDeclH98 {con_doc :: Maybe (LHsDoc GhcPs)
con_doc = Maybe (LHsDoc GhcPs)
forall a. Maybe a
Nothing, Bool
[LHsTyVarBndr Specificity GhcPs]
Maybe (LHsContext GhcPs)
XConDeclH98 GhcPs
LIdP GhcPs
HsConDeclH98Details GhcPs
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_ext :: XConDeclH98 GhcPs
con_name :: LIdP GhcPs
con_forall :: Bool
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_args :: HsConDeclH98Details GhcPs
con_ext :: XConDeclH98 GhcPs
con_name :: LIdP GhcPs
con_forall :: Bool
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_args :: HsConDeclH98Details GhcPs
..}
      ConDecl GhcPs
a -> ConDecl GhcPs
a

    patchContext :: LHsContext GhcPs -> LHsContext GhcPs
    patchContext :: LHsContext GhcPs -> LHsContext GhcPs
patchContext = ([GenLocated SrcSpanAnnA (HsType GhcPs)]
 -> [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a b.
(a -> b) -> GenLocated SrcSpanAnnC a -> GenLocated SrcSpanAnnC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([GenLocated SrcSpanAnnA (HsType GhcPs)]
  -> [GenLocated SrcSpanAnnA (HsType GhcPs)])
 -> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
 -> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> ([GenLocated SrcSpanAnnA (HsType GhcPs)]
    -> [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a b. (a -> b) -> a -> b
$ \case
      [x :: GenLocated SrcSpanAnnA (HsType GhcPs)
x@(L SrcSpanAnnA
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
_))] -> [GenLocated SrcSpanAnnA (HsType GhcPs)
x]
      [x :: GenLocated SrcSpanAnnA (HsType GhcPs)
x@(L SrcSpanAnnA
lx HsType GhcPs
_)] -> [SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lx (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
EpAnn AnnParen
forall ann. EpAnn ann
EpAnnNotUsed LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x)]
      [GenLocated SrcSpanAnnA (HsType GhcPs)]
xs -> [GenLocated SrcSpanAnnA (HsType GhcPs)]
xs

-- | 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 b a. (b -> a -> b) -> b -> [a] -> b
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 (Language -> Maybe Language
forall a. a -> Maybe a
Just Language
Haskell2010)) [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
    Extension
OverloadedRecordDot, -- f.g parses differently
    Extension
OverloadedRecordUpdate, -- qualified fields are not supported
    Extension
OverloadedLabels, -- a#b is parsed differently
    Extension
ExtendedLiterals -- 1#Word32 is parsed differently
  ]

-- | Run a 'GHC.P' computation.
runParser ::
  -- | Computation to run
  GHC.P a ->
  -- | Dynamic flags
  GHC.DynFlags ->
  -- | Module path
  FilePath ->
  -- | Module contents
  Text ->
  -- | Parse result
  GHC.ParseResult a
runParser :: forall a. P a -> DynFlags -> String -> Text -> ParseResult a
runParser P a
parser DynFlags
flags String
filename Text
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 (String -> FastString
GHC.mkFastString String
filename) Int
1 Int
1
    buffer :: StringBuffer
buffer = Text -> StringBuffer
textToStringBuffer Text
input
    parseState :: PState
parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
GHC.initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
flags) StringBuffer
buffer RealSrcLoc
location

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

-- | Detect pragmas in the given input and return them as a collection of
-- 'DynFlags'.
parsePragmasIntoDynFlags ::
  -- | Pre-set 'DynFlags'
  DynFlags ->
  -- | Extra options (provided by user)
  [Located String] ->
  -- | File name (only for source location annotations)
  FilePath ->
  -- | Input for parser
  StringBuffer ->
  IO (Either String (GHC.DriverMessages, DynFlags))
parsePragmasIntoDynFlags :: DynFlags
-> [Located String]
-> String
-> StringBuffer
-> IO (Either String (DriverMessages, DynFlags))
parsePragmasIntoDynFlags DynFlags
flags [Located String]
extraOpts String
filepath StringBuffer
input =
  IO (Either String (DriverMessages, DynFlags))
-> IO (Either String (DriverMessages, DynFlags))
forall (m :: * -> *) a.
ExceptionMonad m =>
m (Either String a) -> m (Either String a)
catchGhcErrors (IO (Either String (DriverMessages, DynFlags))
 -> IO (Either String (DriverMessages, DynFlags)))
-> IO (Either String (DriverMessages, DynFlags))
-> IO (Either String (DriverMessages, DynFlags))
forall a b. (a -> b) -> a -> b
$ do
    let (Messages PsMessage
_warnings, [Located String]
fileOpts) =
          ParserOpts
-> StringBuffer -> String -> (Messages PsMessage, [Located String])
GHC.getOptions
            (DynFlags -> ParserOpts
initParserOpts DynFlags
flags)
            StringBuffer
input
            String
filepath
    (DynFlags
flags', [Located String]
leftovers, DriverMessages
warnings) <-
      DynFlags
-> [Located String]
-> IO (DynFlags, [Located String], DriverMessages)
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String]
-> m (DynFlags, [Located String], DriverMessages)
parseDynamicFilePragma DynFlags
flags ([Located String]
extraOpts [Located String] -> [Located String] -> [Located String]
forall a. Semigroup a => a -> a -> a
<> [Located String]
fileOpts)
    case [Located String] -> Maybe (NonEmpty (Located String))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Located String]
leftovers of
      Maybe (NonEmpty (Located String))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just NonEmpty (Located String)
unrecognizedOpts ->
        OrmoluException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (NonEmpty String -> OrmoluException
OrmoluUnrecognizedOpts (Located String -> String
forall l e. GenLocated l e -> e
unLoc (Located String -> String)
-> NonEmpty (Located String) -> NonEmpty String
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
    Either String (DriverMessages, DynFlags)
-> IO (Either String (DriverMessages, DynFlags))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (DriverMessages, DynFlags)
 -> IO (Either String (DriverMessages, DynFlags)))
-> Either String (DriverMessages, DynFlags)
-> IO (Either String (DriverMessages, DynFlags))
forall a b. (a -> b) -> a -> b
$ (DriverMessages, DynFlags)
-> Either String (DriverMessages, DynFlags)
forall a b. b -> Either a b
Right (DriverMessages
warnings, DynFlags
flags'')

-- | Detect the collection of imports used in the given input.
parseImports ::
  -- | Pre-set 'DynFlags'
  DynFlags ->
  -- | Implicit Prelude?
  Bool ->
  -- | File name (only for source location annotations)
  FilePath ->
  -- | Input for the parser
  StringBuffer ->
  IO (Either String [LImportDecl GhcPs])
parseImports :: DynFlags
-> Bool
-> String
-> StringBuffer
-> IO (Either String [LImportDecl GhcPs])
parseImports DynFlags
flags Bool
implicitPrelude String
filepath StringBuffer
input =
  case P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
forall a. P a -> PState -> ParseResult a
GHC.unP P (Located (HsModule GhcPs))
GHC.parseHeader (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
GHC.initParserState ParserOpts
popts StringBuffer
input RealSrcLoc
loc) of
    GHC.PFailed PState
pst ->
      Either String [LImportDecl GhcPs]
-> IO (Either String [LImportDecl GhcPs])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [LImportDecl GhcPs]
 -> IO (Either String [LImportDecl GhcPs]))
-> Either String [LImportDecl GhcPs]
-> IO (Either String [LImportDecl GhcPs])
forall a b. (a -> b) -> a -> b
$ String -> Either String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. a -> Either a b
Left (Messages PsMessage -> String
forall o. Outputable o => o -> String
showOutputable (PState -> Messages PsMessage
GHC.getPsErrorMessages PState
pst))
    GHC.POk PState
pst Located (HsModule GhcPs)
rdr_module ->
      Either String [LImportDecl GhcPs]
-> IO (Either String [LImportDecl GhcPs])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [LImportDecl GhcPs]
 -> IO (Either String [LImportDecl GhcPs]))
-> Either String [LImportDecl GhcPs]
-> IO (Either String [LImportDecl GhcPs])
forall a b. (a -> b) -> a -> b
$
        let (Messages PsMessage
_warnings, Messages PsMessage
errors) = PState -> (Messages PsMessage, Messages PsMessage)
GHC.getPsMessages PState
pst
         in if Bool -> Bool
not (Messages PsMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages PsMessage
errors)
              then String -> Either String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. a -> Either a b
Left (Messages GhcMessage -> String
forall o. Outputable o => o -> String
showOutputable (PsMessage -> GhcMessage
GHC.GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
errors))
              else
                let hsmod :: HsModule GhcPs
hsmod = Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
rdr_module
                    mmoduleName :: Maybe (XRec GhcPs ModuleName)
mmoduleName = HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
hsmod
                    main_loc :: SrcSpan
main_loc = SrcLoc -> SrcSpan
srcLocSpan (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
GHC.mkFastString String
filepath) Int
1 Int
1)
                    mod' :: GenLocated SrcSpanAnnA ModuleName
mod' = Maybe (XRec GhcPs ModuleName)
Maybe (GenLocated SrcSpanAnnA ModuleName)
mmoduleName Maybe (GenLocated SrcSpanAnnA ModuleName)
-> GenLocated SrcSpanAnnA ModuleName
-> GenLocated SrcSpanAnnA ModuleName
forall a. Maybe a -> a -> a
`orElse` SrcSpanAnnA -> ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
GHC.noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
                    explicitImports :: [LImportDecl GhcPs]
explicitImports = HsModule GhcPs -> [LImportDecl GhcPs]
forall p. HsModule p -> [LImportDecl p]
hsmodImports HsModule GhcPs
hsmod
                    implicitImports :: [LImportDecl GhcPs]
implicitImports =
                      ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
GHC.mkPrelImports (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA ModuleName
mod') SrcSpan
main_loc Bool
implicitPrelude [LImportDecl GhcPs]
explicitImports
                 in [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> Either String [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. b -> Either a b
Right ([LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
explicitImports [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
implicitImports)
  where
    popts :: ParserOpts
popts = DynFlags -> ParserOpts
initParserOpts DynFlags
flags
    loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
GHC.mkFastString String
filepath) Int
1 Int
1

-- | Catch and report GHC errors.
catchGhcErrors :: (ExceptionMonad m) => m (Either String a) -> m (Either String a)
catchGhcErrors :: forall (m :: * -> *) a.
ExceptionMonad m =>
m (Either String a) -> m (Either String a)
catchGhcErrors m (Either String a)
m =
  (GhcException -> m (Either String a))
-> m (Either String a) -> m (Either String a)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
GHC.handleGhcException
    GhcException -> m (Either String a)
forall {m :: * -> *} {a} {b}.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr
    ((SourceError -> m (Either String a))
-> m (Either String a) -> m (Either String a)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError SourceError -> m (Either String a)
forall {m :: * -> *} {a} {b}.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr m (Either String a)
m)
  where
    reportErr :: a -> m (Either String b)
reportErr a
e = Either String b -> m (Either String b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> Either String b -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (a -> String
forall a. Show a => a -> String
show a
e)