{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import GHC.Data.Bag (bagToList)
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.Data.FastString as GHC
import qualified GHC.Driver.CmdLine as GHC
import GHC.Driver.Config.Parser (initParserOpts)
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 qualified GHC.Parser.Header as GHC
import qualified GHC.Parser.Lexer as GHC
import GHC.Types.Error (getMessages)
import qualified GHC.Types.SourceError as GHC (handleSourceError)
import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Utils.Outputable (defaultSDocContext)
import qualified GHC.Utils.Panic as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Fixity (LazyFixityMap)
import Ormolu.Imports (normalizeImports)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Processing.Common
import Ormolu.Processing.Preprocess
import Ormolu.Utils (incSpanLine, showOutputable, textToStringBuffer)
parseModule ::
(MonadIO m) =>
Config RegionDeltas ->
LazyFixityMap ->
FilePath ->
Text ->
m
( [GHC.Warn],
Either (SrcSpan, String) [SourceSnippet]
)
parseModule :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> String
-> Text
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet])
parseModule config :: Config RegionDeltas
config@Config {Bool
[DynOption]
Set PackageName
FixityMap
ColorMode
RegionDeltas
SourceType
cfgDynOptions :: [DynOption]
cfgFixityOverrides :: FixityMap
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 -> FixityMap
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
..} LazyFixityMap
fixityMap String
path Text
rawInput = IO ([Warn], Either (SrcSpan, String) [SourceSnippet])
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Warn], Either (SrcSpan, String) [SourceSnippet])
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet]))
-> IO ([Warn], Either (SrcSpan, String) [SourceSnippet])
-> m ([Warn], Either (SrcSpan, String) [SourceSnippet])
forall a b. (a -> b) -> a -> b
$ do
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
([Warn]
warnings, DynFlags
dynFlags) <-
DynFlags
-> [Located String]
-> String
-> Text
-> IO (Either String ([Warn], DynFlags))
parsePragmasIntoDynFlags DynFlags
baseFlags [Located String]
extraOpts String
path Text
rawInput IO (Either String ([Warn], DynFlags))
-> (Either String ([Warn], DynFlags) -> IO ([Warn], DynFlags))
-> IO ([Warn], 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 ([Warn], DynFlags)
res -> ([Warn], DynFlags) -> IO ([Warn], DynFlags)
forall a. a -> IO a
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 OrmoluException -> IO ([Warn], DynFlags)
forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> String -> OrmoluException
OrmoluParsingFailed SrcSpan
loc 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)
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
-> LazyFixityMap
-> DynFlags
-> String
-> Text
-> IO (Either (SrcSpan, String) ParseResult)
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> 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) LazyFixityMap
fixityMap 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
([Warn], Either (SrcSpan, String) [SourceSnippet])
-> IO ([Warn], Either (SrcSpan, String) [SourceSnippet])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn]
warnings, Either (SrcSpan, String) [SourceSnippet]
snippets)
parseModuleSnippet ::
(MonadIO m) =>
Config RegionDeltas ->
LazyFixityMap ->
DynFlags ->
FilePath ->
Text ->
m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> DynFlags
-> String
-> Text
-> m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet Config {Bool
[DynOption]
Set PackageName
FixityMap
ColorMode
RegionDeltas
SourceType
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgFixityOverrides :: forall region. Config region -> FixityMap
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 :: FixityMap
cfgDependencies :: Set PackageName
cfgUnsafe :: Bool
cfgDebug :: Bool
cfgCheckIdempotence :: Bool
cfgSourceType :: SourceType
cfgColorMode :: ColorMode
cfgRegion :: RegionDeltas
..} LazyFixityMap
fixityMap 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)
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 PsMessage -> String
showErr =
SDoc -> String
forall o. Outputable o => o -> String
showOutputable
(SDoc -> String)
-> (MsgEnvelope PsMessage -> SDoc)
-> MsgEnvelope PsMessage
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
defaultSDocContext
(DecoratedSDoc -> SDoc)
-> (MsgEnvelope PsMessage -> DecoratedSDoc)
-> MsgEnvelope PsMessage
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PsMessage -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage
(PsMessage -> DecoratedSDoc)
-> (MsgEnvelope PsMessage -> PsMessage)
-> MsgEnvelope PsMessage
-> DecoratedSDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope PsMessage -> PsMessage
forall e. MsgEnvelope e -> e
errMsgDiagnostic
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
showErr MsgEnvelope PsMessage
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 P (Located HsModule)
-> DynFlags -> String -> Text -> ParseResult (Located HsModule)
forall a. P a -> DynFlags -> String -> Text -> ParseResult a
runParser P (Located HsModule)
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 -> HsModule
normalizeModule -> HsModule
hsModule)) ->
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 ->
let (Maybe (RealLocated Comment)
stackHeader, [([RealLocated Comment], Pragma)]
pragmas, CommentStream
comments) =
Text
-> HsModule
-> (Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)],
CommentStream)
mkCommentStream Text
input HsModule
hsModule
in ParseResult -> Either (SrcSpan, String) ParseResult
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
}
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
normalizeModule :: HsModule -> HsModule
normalizeModule :: HsModule -> HsModule
normalizeModule HsModule
hsmod =
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere
((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 ((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) GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
LHsContext GhcPs -> LHsContext GhcPs
patchContext)
HsModule
hsmod
{ hsmodImports :: [LImportDecl GhcPs]
hsmodImports =
[LImportDecl GhcPs] -> [LImportDecl GhcPs]
normalizeImports (HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
hsmod),
hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls =
(GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Bool)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDecl GhcPs -> Bool
forall {pass}. HsDecl pass -> Bool
isBlankDocD (HsDecl GhcPs -> Bool)
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsDecl GhcPs) -> HsDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) (HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
hsmod),
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader =
(LHsDoc GhcPs -> Bool)
-> Maybe (LHsDoc GhcPs) -> Maybe (LHsDoc GhcPs)
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not (Bool -> Bool) -> (LHsDoc GhcPs -> Bool) -> LHsDoc GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsDoc GhcPs -> Bool
forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString) (HsModule -> Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader HsModule
hsmod),
hsmodExports :: Maybe (LocatedL [LIE GhcPs])
hsmodExports =
((GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]))
-> (([GenLocated SrcSpanAnnA (IE GhcPs)]
-> [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> ([GenLocated SrcSpanAnnA (IE GhcPs)]
-> [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([GenLocated SrcSpanAnnA (IE GhcPs)]
-> [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
forall a b.
(a -> b) -> GenLocated SrcSpanAnnL a -> GenLocated SrcSpanAnnL b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ((GenLocated SrcSpanAnnA (IE GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (GenLocated SrcSpanAnnA (IE GhcPs) -> Bool)
-> GenLocated SrcSpanAnnA (IE GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IE GhcPs -> Bool
forall {pass}. IE pass -> Bool
isBlankDocIE (IE GhcPs -> Bool)
-> (GenLocated SrcSpanAnnA (IE GhcPs) -> IE GhcPs)
-> GenLocated SrcSpanAnnA (IE GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (IE GhcPs) -> IE GhcPs
forall l e. GenLocated l e -> e
unLoc)) (HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodExports HsModule
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
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 l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc (([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 GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x)]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
xs -> [GenLocated SrcSpanAnnA (HsType GhcPs)]
xs
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]
manualExts :: [Extension]
manualExts :: [Extension]
manualExts =
[ Extension
Arrows,
Extension
Cpp,
Extension
BangPatterns,
Extension
PatternSynonyms,
Extension
RecursiveDo,
Extension
StaticPointers,
Extension
TransformListComp,
Extension
UnboxedTuples,
Extension
MagicHash,
Extension
AlternativeLayoutRule,
Extension
AlternativeLayoutRuleTransitional,
Extension
MonadComprehensions,
Extension
UnboxedSums,
Extension
UnicodeSyntax,
Extension
TemplateHaskell,
Extension
TemplateHaskellQuotes,
Extension
ImportQualifiedPost,
Extension
NegativeLiterals,
Extension
LexicalNegation,
Extension
LinearTypes,
Extension
OverloadedRecordDot,
Extension
OverloadedRecordUpdate
]
runParser ::
GHC.P a ->
GHC.DynFlags ->
FilePath ->
Text ->
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
parsePragmasIntoDynFlags ::
DynFlags ->
[Located String] ->
FilePath ->
Text ->
IO (Either String ([GHC.Warn], DynFlags))
parsePragmasIntoDynFlags :: DynFlags
-> [Located String]
-> String
-> Text
-> IO (Either String ([Warn], DynFlags))
parsePragmasIntoDynFlags DynFlags
flags [Located String]
extraOpts String
filepath Text
str =
IO (Either String ([Warn], DynFlags))
-> IO (Either String ([Warn], DynFlags))
forall {m :: * -> *} {b}.
(MonadMask m, MonadIO m) =>
m (Either String b) -> m (Either String b)
catchErrors (IO (Either String ([Warn], DynFlags))
-> IO (Either String ([Warn], DynFlags)))
-> IO (Either String ([Warn], DynFlags))
-> IO (Either String ([Warn], 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)
(Text -> StringBuffer
textToStringBuffer Text
str)
String
filepath
(DynFlags
flags', [Located String]
leftovers, [Warn]
warnings) <-
DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
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 ([Warn], DynFlags)
-> IO (Either String ([Warn], DynFlags))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ([Warn], DynFlags)
-> IO (Either String ([Warn], DynFlags)))
-> Either String ([Warn], DynFlags)
-> IO (Either String ([Warn], DynFlags))
forall a b. (a -> b) -> a -> b
$ ([Warn], DynFlags) -> Either String ([Warn], DynFlags)
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 =
(GhcException -> m (Either String b))
-> m (Either String b) -> m (Either String b)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
GHC.handleGhcException
GhcException -> m (Either String b)
forall {m :: * -> *} {a} {b}.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr
((SourceError -> m (Either String b))
-> m (Either String b) -> m (Either String b)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError SourceError -> m (Either String b)
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 = 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)