{-# 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.Except
import Data.Char (isSpace)
import Data.Functor
import Data.Generics
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Data.Ord (Down (Down))
import GHC.Data.Bag (bagToList)
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.Data.FastString as GHC
import qualified GHC.Data.StringBuffer as GHC
import qualified GHC.Driver.CmdLine as GHC
import GHC.Driver.Session as GHC
import GHC.DynFlags (baseDynFlags)
import GHC.Hs hiding (UnicodeSyntax)
import GHC.LanguageExtensions.Type (Extension (..))
import qualified GHC.Parser as GHC
import GHC.Parser.Errors.Ppr (pprError)
import qualified GHC.Parser.Header as GHC
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Types.SourceError as GHC (handleSourceError)
import GHC.Types.SrcLoc
import GHC.Utils.Error (Severity (..), errMsgSeverity, errMsgSpan)
import qualified GHC.Utils.Panic as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Fixity (LazyFixityMap)
import Ormolu.Imports (normalizeImports)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Processing.Common
import Ormolu.Processing.Preprocess
import Ormolu.Utils (incSpanLine)
parseModule ::
MonadIO m =>
Config RegionDeltas ->
LazyFixityMap ->
FilePath ->
String ->
m
( [GHC.Warn],
Either (SrcSpan, String) [SourceSnippet]
)
parseModule :: Config RegionDeltas
-> LazyFixityMap
-> FilePath
-> FilePath
-> m ([Warn], Either (SrcSpan, FilePath) [SourceSnippet])
parseModule config :: Config RegionDeltas
config@Config {Bool
[DynOption]
Set FilePath
FixityMap
ColorMode
RegionDeltas
SourceType
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgSourceType :: forall region. Config region -> SourceType
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDependencies :: forall region. Config region -> Set FilePath
cfgFixityOverrides :: forall region. Config region -> FixityMap
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgSourceType :: SourceType
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDependencies :: Set FilePath
cfgFixityOverrides :: FixityMap
cfgDynOptions :: [DynOption]
..} LazyFixityMap
fixityMap 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
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)
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, 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 (Bool -> RegionDeltas -> FilePath -> [Either Text RegionDeltas]
preprocess Bool
cppEnabled 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
-> LazyFixityMap
-> DynFlags
-> FilePath
-> FilePath
-> IO (Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> 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) LazyFixityMap
fixityMap 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 ->
LazyFixityMap ->
DynFlags ->
FilePath ->
String ->
m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet :: Config RegionDeltas
-> LazyFixityMap
-> DynFlags
-> FilePath
-> FilePath
-> m (Either (SrcSpan, FilePath) ParseResult)
parseModuleSnippet Config {Bool
[DynOption]
Set FilePath
FixityMap
ColorMode
RegionDeltas
SourceType
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgSourceType :: SourceType
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDependencies :: Set FilePath
cfgFixityOverrides :: FixityMap
cfgDynOptions :: [DynOption]
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgSourceType :: forall region. Config region -> SourceType
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDependencies :: forall region. Config region -> Set FilePath
cfgFixityOverrides :: forall region. Config region -> FixityMap
cfgDynOptions :: forall region. Config region -> [DynOption]
..} LazyFixityMap
fixityMap 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 pStateErrors :: PState -> Maybe (SrcSpan, FilePath)
pStateErrors PState
pstate =
let errs :: [MsgEnvelope DecoratedSDoc]
errs = (PsError -> MsgEnvelope DecoratedSDoc)
-> [PsError] -> [MsgEnvelope DecoratedSDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError ([PsError] -> [MsgEnvelope DecoratedSDoc])
-> (Bag PsError -> [PsError])
-> Bag PsError
-> [MsgEnvelope DecoratedSDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag PsError -> [PsError]
forall a. Bag a -> [a]
bagToList (Bag PsError -> [MsgEnvelope DecoratedSDoc])
-> Bag PsError -> [MsgEnvelope DecoratedSDoc]
forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
GHC.getErrorMessages PState
pstate
fixupErrSpan :: SrcSpan -> SrcSpan
fixupErrSpan = Int -> SrcSpan -> SrcSpan
incSpanLine (RegionDeltas -> Int
regionPrefixLength RegionDeltas
cfgRegion)
in case (MsgEnvelope DecoratedSDoc -> Down SeverityOrd)
-> [MsgEnvelope DecoratedSDoc] -> [MsgEnvelope DecoratedSDoc]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (SeverityOrd -> Down SeverityOrd
forall a. a -> Down a
Down (SeverityOrd -> Down SeverityOrd)
-> (MsgEnvelope DecoratedSDoc -> SeverityOrd)
-> MsgEnvelope DecoratedSDoc
-> Down SeverityOrd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Severity -> SeverityOrd
SeverityOrd (Severity -> SeverityOrd)
-> (MsgEnvelope DecoratedSDoc -> Severity)
-> MsgEnvelope DecoratedSDoc
-> SeverityOrd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope DecoratedSDoc -> Severity
forall e. MsgEnvelope e -> Severity
errMsgSeverity) [MsgEnvelope DecoratedSDoc]
errs of
[] -> Maybe (SrcSpan, FilePath)
forall a. Maybe a
Nothing
MsgEnvelope DecoratedSDoc
err : [MsgEnvelope DecoratedSDoc]
_ ->
(SrcSpan, FilePath) -> Maybe (SrcSpan, FilePath)
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpan
fixupErrSpan (MsgEnvelope DecoratedSDoc -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope DecoratedSDoc
err), MsgEnvelope DecoratedSDoc -> FilePath
forall a. Show a => a -> FilePath
show MsgEnvelope DecoratedSDoc
err)
parser :: P (Located HsModule)
parser = case SourceType
cfgSourceType of
SourceType
ModuleSource -> P (Located HsModule)
GHC.parseModule
SourceType
SignatureSource -> P (Located HsModule)
GHC.parseSignature
r :: Either (SrcSpan, 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)
parser 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
normalizeModule -> HsModule
hsModule)) ->
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 ->
let (Maybe (RealLocated Comment)
stackHeader, [([RealLocated Comment], Pragma)]
pragmas, CommentStream
comments) =
FilePath
-> HsModule
-> (Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)],
CommentStream)
mkCommentStream FilePath
input HsModule
hsModule
in ParseResult -> Either (SrcSpan, FilePath) ParseResult
forall a b. b -> Either a b
Right
ParseResult :: HsModule
-> SourceType
-> Maybe (RealLocated Comment)
-> [([RealLocated Comment], Pragma)]
-> CommentStream
-> EnumSet Extension
-> FixityMap
-> LazyFixityMap
-> Int
-> ParseResult
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, FilePath) ParseResult
-> IO (Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *) a. Monad m => a -> m a
return Either (SrcSpan, FilePath) ParseResult
r
normalizeModule :: HsModule -> HsModule
normalizeModule :: HsModule -> HsModule
normalizeModule HsModule
hsmod =
(forall a. Data a => a -> a) -> HsModule -> HsModule
(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)
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 p. HsDecl p -> 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 LHsDocString
hsmodHaddockModHeader =
(LHsDocString -> Bool) -> Maybe LHsDocString -> Maybe LHsDocString
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not (Bool -> Bool) -> (LHsDocString -> Bool) -> LHsDocString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> Bool
isBlankDocString (HsDocString -> Bool)
-> (LHsDocString -> HsDocString) -> LHsDocString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsDocString -> HsDocString
forall l e. GenLocated l e -> e
unLoc) (HsModule -> Maybe LHsDocString
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 (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 (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 :: HsDocString -> Bool
isBlankDocString = (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (FilePath -> Bool)
-> (HsDocString -> FilePath) -> HsDocString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> FilePath
unpackHDS
isBlankDocD :: HsDecl p -> Bool
isBlankDocD = \case
DocD XDocD p
_ DocDecl
s -> HsDocString -> Bool
isBlankDocString (HsDocString -> Bool) -> HsDocString -> Bool
forall a b. (a -> b) -> a -> b
$ DocDecl -> HsDocString
docDeclDoc DocDecl
s
HsDecl p
_ -> Bool
False
isBlankDocIE :: IE pass -> Bool
isBlankDocIE = \case
IEGroup XIEGroup pass
_ Int
_ HsDocString
s -> HsDocString -> Bool
isBlankDocString HsDocString
s
IEDoc XIEDoc pass
_ HsDocString
s -> HsDocString -> Bool
isBlankDocString HsDocString
s
IE pass
_ -> Bool
False
dropBlankTypeHaddocks :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
dropBlankTypeHaddocks = \case
L _ (HsDocTy _ ty (L _ ds)) :: LHsType GhcPs
| HsDocString -> Bool
isBlankDocString HsDocString
ds -> LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
GenLocated SrcSpanAnnA (HsType GhcPs)
a -> GenLocated SrcSpanAnnA (HsType GhcPs)
a
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 -> 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 ->
String ->
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 = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
GHC.initParserState (DynFlags -> ParserOpts
opts DynFlags
flags) StringBuffer
buffer RealSrcLoc
location
opts :: DynFlags -> ParserOpts
opts =
EnumSet WarningFlag
-> EnumSet Extension -> Bool -> Bool -> Bool -> Bool -> ParserOpts
GHC.mkParserOpts
(EnumSet WarningFlag
-> EnumSet Extension -> Bool -> Bool -> Bool -> Bool -> ParserOpts)
-> (DynFlags -> EnumSet WarningFlag)
-> DynFlags
-> EnumSet Extension
-> Bool
-> Bool
-> Bool
-> Bool
-> ParserOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> EnumSet WarningFlag
GHC.warningFlags
(DynFlags
-> EnumSet Extension -> Bool -> Bool -> Bool -> Bool -> ParserOpts)
-> (DynFlags -> EnumSet Extension)
-> DynFlags
-> Bool
-> Bool
-> Bool
-> Bool
-> ParserOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DynFlags -> EnumSet Extension
GHC.extensionFlags
(DynFlags -> Bool -> Bool -> Bool -> Bool -> ParserOpts)
-> (DynFlags -> Bool)
-> DynFlags
-> Bool
-> Bool
-> Bool
-> ParserOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DynFlags -> Bool
GHC.safeImportsOn
(DynFlags -> Bool -> Bool -> Bool -> ParserOpts)
-> (DynFlags -> Bool) -> DynFlags -> Bool -> Bool -> ParserOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GeneralFlag -> DynFlags -> Bool
GHC.gopt GeneralFlag
GHC.Opt_Haddock
(DynFlags -> Bool -> Bool -> ParserOpts)
-> (DynFlags -> Bool) -> DynFlags -> Bool -> ParserOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GeneralFlag -> DynFlags -> Bool
GHC.gopt GeneralFlag
GHC.Opt_KeepRawTokenStream
(DynFlags -> Bool -> ParserOpts)
-> (DynFlags -> Bool) -> DynFlags -> ParserOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> DynFlags -> Bool
forall a b. a -> b -> a
const Bool
True
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
parsePragmasIntoDynFlags ::
DynFlags ->
[Located String] ->
FilePath ->
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)