{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Ormolu.Parser
( parseModule,
manualExts,
)
where
import Bag (bagToList)
import qualified CmdLineParser as GHC
import Control.Exception
import Control.Monad.IO.Class
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import Data.Ord (Down (Down))
import qualified Data.Text as T
import DynFlags as GHC
import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
import qualified FastString as GHC
import GHC hiding (IE, UnicodeSyntax)
import GHC.DynFlags (baseDynFlags)
import GHC.LanguageExtensions.Type (Extension (..))
import qualified HeaderInfo as GHC
import qualified HscTypes as GHC
import qualified Lexer as GHC
import Ormolu.Config
import Ormolu.Exception
import Ormolu.Parser.Anns
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Result
import Ormolu.Processing.Preprocess (preprocess)
import Ormolu.Utils (incSpanLine)
import qualified Panic as GHC
import qualified Parser as GHC
import qualified StringBuffer as GHC
parseModule ::
MonadIO m =>
Config RegionDeltas ->
FilePath ->
String ->
m
( [GHC.Warn],
Either (SrcSpan, String) ParseResult
)
parseModule :: Config RegionDeltas
-> FilePath
-> FilePath
-> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
parseModule Config {Bool
[DynOption]
PrinterOpts
RegionDeltas
cfgPrinterOpts :: forall region. Config region -> PrinterOpts
cfgRegion :: forall region. Config region -> region
cfgCheckIdempotence :: forall region. Config region -> Bool
cfgDebug :: forall region. Config region -> Bool
cfgUnsafe :: forall region. Config region -> Bool
cfgDynOptions :: forall region. Config region -> [DynOption]
cfgPrinterOpts :: PrinterOpts
cfgRegion :: RegionDeltas
cfgCheckIdempotence :: Bool
cfgDebug :: Bool
cfgUnsafe :: Bool
cfgDynOptions :: [DynOption]
..} FilePath
path FilePath
rawInput = IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
-> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
-> m ([Warn], Either (SrcSpan, FilePath) ParseResult))
-> IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
-> m ([Warn], Either (SrcSpan, FilePath) ParseResult)
forall a b. (a -> b) -> a -> b
$ do
let (FilePath
literalPrefix, FilePath
input, FilePath
literalSuffix, [Located FilePath]
extraComments) =
FilePath
-> FilePath
-> RegionDeltas
-> (FilePath, FilePath, FilePath, [Located FilePath])
preprocess FilePath
path FilePath
rawInput RegionDeltas
cfgRegion
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 useRecordDot :: Bool
useRecordDot =
FilePath
"record-dot-preprocessor" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> FilePath
pgm_F DynFlags
dynFlags
Bool -> Bool -> Bool
|| (ModuleName -> Bool) -> [ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
((FilePath
"RecordDotPreprocessor" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==) (FilePath -> Bool)
-> (ModuleName -> FilePath) -> ModuleName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FilePath
moduleNameString)
(DynFlags -> [ModuleName]
pluginModNames DynFlags
dynFlags)
pStateErrors :: PState -> Maybe (SrcSpan, FilePath)
pStateErrors = \PState
pstate ->
let errs :: [ErrMsg]
errs = Bag ErrMsg -> [ErrMsg]
forall a. Bag a -> [a]
bagToList (Bag ErrMsg -> [ErrMsg]) -> Bag ErrMsg -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> Bag ErrMsg
GHC.getErrorMessages PState
pstate DynFlags
dynFlags
fixupErrSpan :: SrcSpan -> SrcSpan
fixupErrSpan = Int -> SrcSpan -> SrcSpan
incSpanLine (RegionDeltas -> Int
regionPrefixLength RegionDeltas
cfgRegion)
in case (ErrMsg -> Down SeverityOrd) -> [ErrMsg] -> [ErrMsg]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (SeverityOrd -> Down SeverityOrd
forall a. a -> Down a
Down (SeverityOrd -> Down SeverityOrd)
-> (ErrMsg -> SeverityOrd) -> ErrMsg -> Down SeverityOrd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Severity -> SeverityOrd
SeverityOrd (Severity -> SeverityOrd)
-> (ErrMsg -> Severity) -> ErrMsg -> SeverityOrd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> Severity
errMsgSeverity) [ErrMsg]
errs of
[] -> Maybe (SrcSpan, FilePath)
forall a. Maybe a
Nothing
ErrMsg
err : [ErrMsg]
_ ->
(SrcSpan, FilePath) -> Maybe (SrcSpan, FilePath)
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpan
fixupErrSpan (ErrMsg -> SrcSpan
errMsgSpan ErrMsg
err), ErrMsg -> FilePath
forall a. Show a => a -> FilePath
show ErrMsg
err)
r :: Either (SrcSpan, FilePath) ParseResult
r = case P (Located (HsModule GhcPs))
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located (HsModule GhcPs))
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located (HsModule GhcPs))
GHC.parseModule DynFlags
dynFlags FilePath
path FilePath
input of
GHC.PFailed PState
pstate ->
case PState -> Maybe (SrcSpan, FilePath)
pStateErrors PState
pstate of
Just (SrcSpan, FilePath)
err -> (SrcSpan, FilePath) -> Either (SrcSpan, FilePath) ParseResult
forall a b. a -> Either a b
Left (SrcSpan, FilePath)
err
Maybe (SrcSpan, FilePath)
Nothing -> FilePath -> Either (SrcSpan, FilePath) ParseResult
forall a. HasCallStack => FilePath -> a
error FilePath
"PFailed does not have an error"
GHC.POk PState
pstate (L SrcSpan
_ HsModule GhcPs
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, [Shebang]
shebangs, [([RealLocated Comment], Pragma)]
pragmas, CommentStream
comments) =
FilePath
-> [Located FilePath]
-> PState
-> (Maybe (RealLocated Comment), [Shebang],
[([RealLocated Comment], Pragma)], CommentStream)
mkCommentStream FilePath
input [Located FilePath]
extraComments PState
pstate
in ParseResult -> Either (SrcSpan, FilePath) ParseResult
forall a b. b -> Either a b
Right
ParseResult :: HsModule GhcPs
-> Anns
-> Maybe (RealLocated Comment)
-> [Shebang]
-> [([RealLocated Comment], Pragma)]
-> CommentStream
-> Bool
-> Bool
-> Text
-> Text
-> ParseResult
ParseResult
{ prParsedSource :: HsModule GhcPs
prParsedSource = HsModule GhcPs
hsModule,
prAnns :: Anns
prAnns = PState -> Anns
mkAnns PState
pstate,
prStackHeader :: Maybe (RealLocated Comment)
prStackHeader = Maybe (RealLocated Comment)
stackHeader,
prShebangs :: [Shebang]
prShebangs = [Shebang]
shebangs,
prPragmas :: [([RealLocated Comment], Pragma)]
prPragmas = [([RealLocated Comment], Pragma)]
pragmas,
prCommentStream :: CommentStream
prCommentStream = CommentStream
comments,
prUseRecordDot :: Bool
prUseRecordDot = Bool
useRecordDot,
prImportQualifiedPost :: Bool
prImportQualifiedPost =
Extension -> DynFlags -> Bool
GHC.xopt Extension
ImportQualifiedPost DynFlags
dynFlags,
prLiteralPrefix :: Text
prLiteralPrefix = FilePath -> Text
T.pack FilePath
literalPrefix,
prLiteralSuffix :: Text
prLiteralSuffix = FilePath -> Text
T.pack FilePath
literalSuffix
}
([Warn], Either (SrcSpan, FilePath) ParseResult)
-> IO ([Warn], Either (SrcSpan, FilePath) ParseResult)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Warn]
warnings, Either (SrcSpan, FilePath) ParseResult
r)
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts DynFlags
flags = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' DynFlags -> Extension -> DynFlags
xopt_set DynFlags
flags [Extension]
autoExts
where
autoExts :: [Extension]
autoExts = [Extension]
allExts [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Extension]
manualExts
allExts :: [Extension]
allExts = [Extension
forall a. Bounded a => a
minBound .. Extension
forall a. Bounded a => a
maxBound]
manualExts :: [Extension]
manualExts :: [Extension]
manualExts =
[ Extension
Arrows,
Extension
Cpp,
Extension
BangPatterns,
Extension
PatternSynonyms,
Extension
RecursiveDo,
Extension
StaticPointers,
Extension
TransformListComp,
Extension
UnboxedTuples,
Extension
MagicHash,
Extension
TypeApplications,
Extension
AlternativeLayoutRule,
Extension
AlternativeLayoutRuleTransitional,
Extension
MonadComprehensions,
Extension
UnboxedSums,
Extension
UnicodeSyntax,
Extension
TemplateHaskellQuotes,
Extension
ImportQualifiedPost
]
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
GHC.mkRealSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
filename) Int
1 Int
1
buffer :: StringBuffer
buffer = FilePath -> StringBuffer
GHC.stringToStringBuffer FilePath
input
parseState :: PState
parseState = DynFlags -> StringBuffer -> RealSrcLoc -> PState
GHC.mkPState DynFlags
flags StringBuffer
buffer RealSrcLoc
location
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.
ExceptionMonad 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 opts :: [Located FilePath]
opts = 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]
opts [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. Semigroup a => a -> a -> a
<> [Located FilePath]
extraOpts)
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 a. HasSrcSpan a => a -> SrcSpanLess a
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.
ExceptionMonad 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)