{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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.Functor.Identity (Identity (..))
import Data.Generics
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import GHC.Data.Bag (bagToList)
import GHC.Data.EnumSet qualified as EnumSet
import GHC.Data.FastString qualified as GHC
import GHC.Driver.CmdLine qualified 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 GHC.Parser qualified as GHC
import GHC.Parser.Header qualified as GHC
import GHC.Parser.Lexer qualified as GHC
import GHC.Types.Error (NoDiagnosticOpts (..), getMessages)
import GHC.Types.SourceError qualified as GHC (handleSourceError)
import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Utils.Outputable (defaultSDocContext)
import GHC.Utils.Panic qualified as GHC
import Ormolu.Config
import Ormolu.Config.Gen (SingleConstraintParens (..))
import Ormolu.Exception
import Ormolu.Fixity (LazyFixityMap)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Processing.Common
import Ormolu.Processing.Preprocess
import Ormolu.Utils (incSpanLine, 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
PrinterOptsTotal
ColorMode
RegionDeltas
SourceType
cfgPrinterOpts :: forall region. Config region -> PrinterOptsTotal
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgSourceType :: forall region. Config region -> SourceType
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDependencies :: forall region. Config region -> Set PackageName
cfgFixityOverrides :: forall region. Config region -> FixityMap
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgPrinterOpts :: PrinterOptsTotal
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgSourceType :: SourceType
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDependencies :: Set PackageName
cfgFixityOverrides :: FixityMap
cfgDynOptions :: [DynOption]
..} LazyFixityMap
fixityMap String
path Text
rawInput = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right ([Warn], DynFlags)
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn], DynFlags)
res
Left String
err ->
let loc :: SrcSpan
loc =
SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan
(FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
GHC.mkFastString String
path) Int
1 Int
1)
(FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
GHC.mkFastString String
path) Int
1 Int
1)
in forall e a. Exception e => e -> IO a
throwIO (SrcSpan -> String -> OrmoluException
OrmoluParsingFailed SrcSpan
loc String
err)
let cppEnabled :: Bool
cppEnabled = forall a. Enum a => a -> EnumSet a -> Bool
EnumSet.member Extension
Cpp (DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags)
Either (SrcSpan, String) [SourceSnippet]
snippets <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Bool -> RegionDeltas -> Text -> [Either Text RegionDeltas]
preprocess Bool
cppEnabled RegionDeltas
cfgRegion Text
rawInput) forall a b. (a -> b) -> a -> b
$ \case
Right RegionDeltas
region ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseResult -> SourceSnippet
ParsedSnippet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> DynFlags
-> String
-> Text
-> m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet (Config RegionDeltas
config forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> RegionDeltas
region) LazyFixityMap
fixityMap DynFlags
dynFlags String
path Text
rawInput
Left Text
raw -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> SourceSnippet
RawSnippet Text
raw
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Warn]
warnings, Either (SrcSpan, String) [SourceSnippet]
snippets)
parseModuleSnippet ::
(MonadIO m) =>
Config RegionDeltas ->
LazyFixityMap ->
DynFlags ->
FilePath ->
Text ->
m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet :: forall (m :: * -> *).
MonadIO m =>
Config RegionDeltas
-> LazyFixityMap
-> DynFlags
-> String
-> Text
-> m (Either (SrcSpan, String) ParseResult)
parseModuleSnippet config :: Config RegionDeltas
config@Config {Bool
[DynOption]
Set PackageName
FixityMap
PrinterOptsTotal
ColorMode
RegionDeltas
SourceType
cfgPrinterOpts :: PrinterOptsTotal
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgSourceType :: SourceType
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDependencies :: Set PackageName
cfgFixityOverrides :: FixityMap
cfgDynOptions :: [DynOption]
cfgPrinterOpts :: forall region. Config region -> PrinterOptsTotal
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgSourceType :: forall region. Config region -> SourceType
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDependencies :: forall region. Config region -> Set PackageName
cfgFixityOverrides :: forall region. Config region -> FixityMap
cfgDynOptions :: forall region. Config region -> [DynOption]
..} LazyFixityMap
fixityMap DynFlags
dynFlags String
path Text
rawInput = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let (Text
input, Int
indent) = Text -> (Text, Int)
removeIndentation forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegionDeltas -> Text -> Text
linesInRegion RegionDeltas
cfgRegion forall a b. (a -> b) -> a -> b
$ Text
rawInput
let pStateErrors :: PState -> Maybe (SrcSpan, String)
pStateErrors PState
pstate =
let errs :: [MsgEnvelope PsMessage]
errs = forall a. Bag a -> [a]
bagToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Messages e -> Bag (MsgEnvelope e)
getMessages 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 (forall e. MsgEnvelope e -> e
errMsgDiagnostic -> a
err) = String
codeMsg forall a. Semigroup a => a -> a -> a
<> String
msg
where
codeMsg :: String
codeMsg = case forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
err of
Just DiagnosticCode
code -> String
"[" forall a. Semigroup a => a -> a -> a
<> forall o. Outputable o => o -> String
showOutputable DiagnosticCode
code forall a. Semigroup a => a -> a -> a
<> String
"] "
Maybe DiagnosticCode
Nothing -> String
""
msg :: String
msg =
forall o. Outputable o => o -> String
showOutputable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
defaultSDocContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage NoDiagnosticOpts
NoDiagnosticOpts
forall a b. (a -> b) -> a -> b
$ a
err
in case forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Severity -> Int
rateSeverity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. MsgEnvelope e -> Severity
errMsgSeverity) [MsgEnvelope PsMessage]
errs of
[] -> forall a. Maybe a
Nothing
MsgEnvelope PsMessage
err : [MsgEnvelope PsMessage]
_ ->
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpan
fixupErrSpan (forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope PsMessage
err), 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 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 -> forall a b. a -> Either a b
Left (SrcSpan, String)
err
Maybe (SrcSpan, String)
Nothing -> forall a. HasCallStack => String -> a
error String
"PFailed does not have an error"
GHC.POk PState
pstate (L SrcSpan
_ (Config RegionDeltas -> HsModule GhcPs -> HsModule GhcPs
normalizeModule Config RegionDeltas
config -> HsModule GhcPs
hsModule)) ->
case PState -> Maybe (SrcSpan, String)
pStateErrors PState
pstate of
Just (SrcSpan, String)
err -> forall a b. a -> Either a b
Left (SrcSpan, String)
err
Maybe (SrcSpan, String)
Nothing ->
let (Maybe (RealLocated Comment)
stackHeader, [([RealLocated Comment], Pragma)]
pragmas, CommentStream
comments) =
Text
-> HsModule GhcPs
-> (Maybe (RealLocated Comment), [([RealLocated Comment], Pragma)],
CommentStream)
mkCommentStream Text
input HsModule GhcPs
hsModule
in forall a b. b -> Either a b
Right
ParseResult
{ prParsedSource :: HsModule GhcPs
prParsedSource = HsModule GhcPs
hsModule,
prSourceType :: SourceType
prSourceType = SourceType
cfgSourceType,
prStackHeader :: Maybe (RealLocated Comment)
prStackHeader = Maybe (RealLocated Comment)
stackHeader,
prPragmas :: [([RealLocated Comment], Pragma)]
prPragmas = [([RealLocated Comment], Pragma)]
pragmas,
prCommentStream :: CommentStream
prCommentStream = CommentStream
comments,
prExtensions :: EnumSet Extension
prExtensions = DynFlags -> EnumSet Extension
GHC.extensionFlags DynFlags
dynFlags,
prFixityOverrides :: FixityMap
prFixityOverrides = FixityMap
cfgFixityOverrides,
prFixityMap :: LazyFixityMap
prFixityMap = LazyFixityMap
fixityMap,
prIndent :: Int
prIndent = Int
indent
}
forall (m :: * -> *) a. Monad m => a -> m a
return Either (SrcSpan, String) ParseResult
r
normalizeModule :: Config RegionDeltas -> HsModule GhcPs -> HsModule GhcPs
normalizeModule :: Config RegionDeltas -> HsModule GhcPs -> HsModule GhcPs
normalizeModule Config {Bool
[DynOption]
Set PackageName
FixityMap
PrinterOptsTotal
ColorMode
RegionDeltas
SourceType
cfgPrinterOpts :: PrinterOptsTotal
cfgRegion :: RegionDeltas
cfgColorMode :: ColorMode
cfgSourceType :: SourceType
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDependencies :: Set PackageName
cfgFixityOverrides :: FixityMap
cfgDynOptions :: [DynOption]
cfgPrinterOpts :: forall region. Config region -> PrinterOptsTotal
cfgRegion :: forall region. Config region -> region
cfgColorMode :: forall region. Config region -> ColorMode
cfgSourceType :: forall region. Config region -> SourceType
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDependencies :: forall region. Config region -> Set PackageName
cfgFixityOverrides :: forall region. Config region -> FixityMap
cfgDynOptions :: forall region. Config region -> [DynOption]
..} HsModule GhcPs
hsmod =
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere
(forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
extT (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
dropBlankTypeHaddocks) LHsContext GhcPs -> LHsContext GhcPs
patchContext)
HsModule GhcPs
hsmod
{ hsmodImports :: [LImportDecl GhcPs]
hsmodImports =
forall p. HsModule p -> [LImportDecl p]
hsmodImports HsModule GhcPs
hsmod,
hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls =
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {pass}. HsDecl pass -> Bool
isBlankDocD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) (forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
hsmod),
hsmodExt :: XCModule GhcPs
hsmodExt =
(forall p. HsModule p -> XCModule p
hsmodExt HsModule GhcPs
hsmod)
{ hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader =
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString) (XModulePs -> Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader (forall p. HsModule p -> XCModule p
hsmodExt HsModule GhcPs
hsmod))
},
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports =
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {pass}. IE pass -> Bool
isBlankDocIE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)) (forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodExports HsModule GhcPs
hsmod)
}
where
isBlankDocString :: GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> String
renderHsDocString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
isBlankDocD :: HsDecl pass -> Bool
isBlankDocD = \case
DocD XDocD pass
_ DocDecl pass
s -> forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString forall a b. (a -> b) -> a -> b
$ 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 -> forall {l} {pass}.
GenLocated l (WithHsDocIdentifiers HsDocString pass) -> Bool
isBlankDocString LHsDoc pass
s
IEDoc XIEDoc pass
_ LHsDoc pass
s -> 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
| 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \case
[x :: GenLocated SrcSpanAnnA (HsType GhcPs)
x@(L SrcSpanAnnA
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
t))] -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
unwrapParens GenLocated SrcSpanAnnA (HsType GhcPs)
x LHsType GhcPs
t
[x :: GenLocated SrcSpanAnnA (HsType GhcPs)
x@(L SrcSpanAnnA
_ HsType GhcPs
_)] -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
wrapParens GenLocated SrcSpanAnnA (HsType GhcPs)
x
[GenLocated SrcSpanAnnA (HsType GhcPs)]
xs -> [GenLocated SrcSpanAnnA (HsType GhcPs)]
xs
constraintParens :: SingleConstraintParens
constraintParens = forall a. Identity a -> a
runIdentity (forall (f :: * -> *). PrinterOpts f -> f SingleConstraintParens
poSingleConstraintParens PrinterOptsTotal
cfgPrinterOpts)
unwrapParens :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
unwrapParens GenLocated SrcSpanAnnA (HsType GhcPs)
outer GenLocated SrcSpanAnnA (HsType GhcPs)
inner = case SingleConstraintParens
constraintParens of
SingleConstraintParens
ConstraintNever -> [GenLocated SrcSpanAnnA (HsType GhcPs)
inner]
SingleConstraintParens
_ -> [GenLocated SrcSpanAnnA (HsType GhcPs)
outer]
wrapParens :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
wrapParens x :: GenLocated SrcSpanAnnA (HsType GhcPs)
x@(L SrcSpanAnnA
lx HsType GhcPs
_) = case SingleConstraintParens
constraintParens of
SingleConstraintParens
ConstraintAlways -> [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lx (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall ann. EpAnn ann
EpAnnNotUsed GenLocated SrcSpanAnnA (HsType GhcPs)
x)]
SingleConstraintParens
_ -> [GenLocated SrcSpanAnnA (HsType GhcPs)
x]
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts DynFlags
flags = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' DynFlags -> Extension -> DynFlags
xopt_set (DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
flags (forall a. a -> Maybe a
Just Language
Haskell2010)) [Extension]
autoExts
where
autoExts :: [Extension]
autoExts = [Extension]
allExts forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Extension]
manualExts
allExts :: [Extension]
allExts = [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
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,
Extension
OverloadedLabels
]
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 = 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 =
forall {m :: * -> *} {b}.
(MonadMask m, MonadIO m) =>
m (Either String b) -> m (Either String b)
catchErrors forall a b. (a -> b) -> a -> b
$ do
let (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) <-
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
flags ([Located String]
extraOpts forall a. Semigroup a => a -> a -> a
<> [Located String]
fileOpts)
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Located String]
leftovers of
Maybe (NonEmpty (Located String))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just NonEmpty (Located String)
unrecognizedOpts ->
forall e a. Exception e => e -> IO a
throwIO (NonEmpty String -> OrmoluException
OrmoluUnrecognizedOpts (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Located String)
unrecognizedOpts))
let flags'' :: DynFlags
flags'' = DynFlags
flags' DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ([Warn]
warnings, DynFlags
flags'')
where
catchErrors :: m (Either String b) -> m (Either String b)
catchErrors m (Either String b)
act =
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
GHC.handleGhcException
forall {m :: * -> *} {a} {b}.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr
(forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
GHC.handleSourceError forall {m :: * -> *} {a} {b}.
(Monad m, Show a) =>
a -> m (Either String b)
reportErr m (Either String b)
act)
reportErr :: a -> m (Either String b)
reportErr a
e = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show a
e)