{-# 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
import Control.Monad.IO.Class
import Data.List ((\\), foldl', isPrefixOf, sortOn)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes)
import Data.Ord (Down (Down))
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 qualified Panic as GHC
import qualified Parser as GHC
import qualified StringBuffer as GHC
parseModule ::
MonadIO m =>
Config ->
FilePath ->
String ->
m
( [GHC.Warn],
Either (SrcSpan, String) ParseResult
)
parseModule Config {..} path input' = liftIO $ do
let (input, extraComments) = extractCommentsFromLines path input'
let baseFlags =
GHC.setGeneralFlag'
GHC.Opt_Haddock
(setDefaultExts baseDynFlags)
extraOpts = dynOptionToLocatedStr <$> cfgDynOptions
(warnings, dynFlags) <-
parsePragmasIntoDynFlags baseFlags extraOpts path input' >>= \case
Right res -> pure res
Left err ->
let loc =
mkSrcSpan
(mkSrcLoc (GHC.mkFastString path) 1 1)
(mkSrcLoc (GHC.mkFastString path) 1 1)
in throwIO (OrmoluParsingFailed loc err)
when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
throwIO (OrmoluCppEnabled path)
let useRecordDot =
"record-dot-preprocessor" == pgm_F dynFlags
|| any
(("RecordDotPreprocessor" ==) . moduleNameString)
(pluginModNames dynFlags)
pStateErrors = \pstate ->
let errs = bagToList $ GHC.getErrorMessages pstate dynFlags
in case sortOn (Down . SeverityOrd . errMsgSeverity) errs of
[] -> Nothing
err : _ -> Just (errMsgSpan err, show err)
r = case runParser GHC.parseModule dynFlags path input of
GHC.PFailed pstate ->
case pStateErrors pstate of
Just err -> Left err
Nothing -> error "invariant violation: PFailed does not have an error"
GHC.POk pstate pmod ->
case pStateErrors pstate of
Just err -> Left err
Nothing ->
let (comments, exts, shebangs) = mkCommentStream extraComments pstate
in Right
ParseResult
{ prParsedSource = pmod,
prAnns = mkAnns pstate,
prCommentStream = comments,
prExtensions = exts,
prShebangs = shebangs,
prUseRecordDot = useRecordDot,
prImportQualifiedPost =
GHC.xopt ImportQualifiedPost dynFlags
}
return (warnings, r)
manualExts :: [Extension]
manualExts =
[ Arrows,
Cpp,
BangPatterns,
PatternSynonyms,
RecursiveDo,
StaticPointers,
TransformListComp,
UnboxedTuples,
MagicHash,
TypeApplications,
AlternativeLayoutRule,
AlternativeLayoutRuleTransitional,
MonadComprehensions,
UnboxedSums,
UnicodeSyntax,
TemplateHaskellQuotes,
ImportQualifiedPost
]
runParser ::
GHC.P a ->
GHC.DynFlags ->
FilePath ->
String ->
GHC.ParseResult a
runParser parser flags filename input = GHC.unP parser parseState
where
location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
buffer = GHC.stringToStringBuffer input
parseState = GHC.mkPState flags buffer location
extractCommentsFromLines ::
FilePath ->
String ->
(String, [Located String])
extractCommentsFromLines path =
unlines' . unzip . zipWith (extractCommentFromLine path) [1 ..] . lines
where
unlines' (a, b) = (unlines a, catMaybes b)
extractCommentFromLine ::
FilePath ->
Int ->
String ->
(String, Maybe (Located String))
extractCommentFromLine path line s
| "{-# LINE" `isPrefixOf` s =
let (pragma, res) = getPragma s
size = length pragma
ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
in (res, Just $ L ss pragma)
| isShebang s =
let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
in ("", Just $ L ss s)
| otherwise = (s, Nothing)
where
mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
getPragma ::
String ->
(String, String)
getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
getPragma s@(x : xs)
| "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
| otherwise =
let (prag, remline) = getPragma xs
in (x : prag, ' ' : remline)
setDefaultExts :: DynFlags -> DynFlags
setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
where
autoExts = allExts \\ manualExts
allExts = [minBound .. maxBound]
parsePragmasIntoDynFlags ::
DynFlags ->
[Located String] ->
FilePath ->
String ->
IO (Either String ([GHC.Warn], DynFlags))
parsePragmasIntoDynFlags flags extraOpts filepath str =
catchErrors $ do
let opts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath
(flags', leftovers, warnings) <-
parseDynamicFilePragma flags (opts <> extraOpts)
case NE.nonEmpty leftovers of
Nothing -> return ()
Just unrecognizedOpts ->
throwIO (OrmoluUnrecognizedOpts (unLoc <$> unrecognizedOpts))
let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream
return $ Right (warnings, flags'')
where
catchErrors act =
GHC.handleGhcException
reportErr
(GHC.handleSourceError reportErr act)
reportErr e = return $ Left (show e)
newtype SeverityOrd = SeverityOrd Severity
instance Eq SeverityOrd where
s1 == s2 = compare s1 s2 == EQ
instance Ord SeverityOrd where
compare (SeverityOrd s1) (SeverityOrd s2) =
compare (f s1) (f s2)
where
f :: Severity -> Int
f SevOutput = 1
f SevFatal = 2
f SevInteractive = 3
f SevDump = 4
f SevInfo = 5
f SevWarning = 6
f SevError = 7