{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal
( Parsing.parseModule
, Parsing.parseModuleFromString
, parsePrintModule
, parsePrintModuleTests
, processModule
, pPrintModuleAndCheck
-- re-export from utils:
, extractCommentConfigs
, TraceFunc(TraceFunc)
)
where
import Control.Monad.Trans.Except
import Data.CZipWith
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL
import qualified GHC hiding ( parseModule )
import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.InlineParsing
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.Brittany.Internal.S1_Parsing
as Parsing
import Language.Haskell.Brittany.Internal.StepOrchestrate
( processModule )
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
-- | Exposes the transformation in an pseudo-pure fashion. The signature
-- contains `IO` due to the GHC API not exposing a pure parsing function, but
-- there should be no observable effects.
--
-- Note that this function ignores/resets all config values regarding
-- debugging, i.e. it will never use `trace`/write to stderr.
--
-- Note that the ghc parsing function used internally currently is wrapped in
-- `mask_`, so cannot be killed easily. If you don't control the input, you
-- may wish to put some proper upper bound on the input's size as a timeout
-- won't do.
parsePrintModule
:: TraceFunc -> Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
let config =
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes =
config_pp & _ppconf_hackAroundIncludes & confUnpack
(parsedSource, hasCPP) <- do
let hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s
else s
let hackTransform = if hackAroundIncludes
then List.intercalate "\n" . fmap hackF . lines'
else id
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
parseResult <- lift $ Parsing.parseModuleFromString
ghcOptions
"stdin"
cppCheckFunc
(hackTransform $ Text.unpack inputText)
case parseResult of
Left err -> throwE [ErrorInput err]
Right x -> pure x
(inlineConf, perItemConf) <-
mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
$ extractCommentConfigs (useTraceFunc traceFunc) parsedSource
let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting =
moduleConfig & _conf_disable_formatting & confUnpack
if disableFormatting
then do
return inputText
else do
(errsWarns, outputTextL) <- do
let omitCheck =
moduleConfig
& _conf_errorHandling
& _econf_omit_output_valid_check
& confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then lift $ processModule traceFunc moduleConfig perItemConf parsedSource
else lift $ pPrintModuleAndCheck traceFunc
moduleConfig
perItemConf
parsedSource
let hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes
then
( ews
, TextL.intercalate (TextL.pack "\n")
$ hackF
<$> TextL.splitOn (TextL.pack "\n") outRaw
)
else (ews, outRaw)
let customErrOrder ErrorInput{} = 5
customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnusedComments{} = 3
customErrOrder ErrorUnknownNode{} = 4
customErrOrder ErrorMacroConfig{} = 6
let hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns)
if hasErrors
then throwE $ errsWarns
else pure $ TextL.toStrict outputTextL
-- | Additionally checks that the output compiles again, appending an error
-- if it does not.
pPrintModuleAndCheck
:: TraceFunc
-> Config
-> PerItemConfig
-> GHC.ParsedSource
-> IO ([BrittanyError], TextL.Text)
pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
(errs, output) <- processModule traceFunc conf inlineConf parsedModule
parseResult <- Parsing.parseModuleFromString ghcOptions
"output"
(\_ -> return $ Right ())
(TextL.unpack output)
let errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck]
Right{} -> []
return (errs', output)
-- used for testing mostly, currently.
-- TODO: use parsePrintModule instead and remove this function.
parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text)
parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input
parseResult <- Parsing.parseModuleFromString
(conf & _conf_forward & _options_ghc & runIdentity)
filename
(const . pure $ Right ())
inputStr
case parseResult of
Left err -> return $ Left err
Right (parsedModule, _) -> runExceptT $ do
(inlineConf, perItemConf) <-
mapExceptT
(fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id))
$ extractCommentConfigs (\_ -> pure ()) parsedModule
let moduleConf = cZipWith fromOptionIdentity conf inlineConf
let omitCheck =
conf
& _conf_errorHandling
.> _econf_omit_output_valid_check
.> confUnpack
(errs, ltext) <- if omitCheck
then lift $ processModule (TraceFunc $ \_ -> pure ())
moduleConf
perItemConf
parsedModule
else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
moduleConf
perItemConf
parsedModule
if null errs
then pure $ TextL.toStrict $ ltext
else throwE
$ "pretty printing error(s):\n"
++ List.unlines (errorToString <$> errs)
where
errorToString :: BrittanyError -> String
errorToString = \case
ErrorInput str -> str
ErrorUnusedComment _ -> "ErrorUnusedComment"
ErrorUnusedComments _ _ _ -> "ErrorUnusedComments"
LayoutWarning str -> str
ErrorUnknownNode str _ -> str
ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
ErrorOutputCheck -> "Output is not syntactically valid."
-- this approach would for if there was a pure GHC.parseDynamicFilePragma.
-- Unfortunately that does not exist yet, so we cannot provide a nominally
-- pure interface.
-- parsePrintModuleTests :: Text -> Either String Text
-- parsePrintModuleTests input = do
-- let dflags = GHC.unsafeGlobalDynFlags
-- let fakeFileName = "SomeTestFakeFileName.hs"
-- let pragmaInfo = GHC.getOptions
-- dflags
-- (GHC.stringToStringBuffer $ Text.unpack input)
-- fakeFileName
-- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo
-- let parseResult = ExactPrint.Parsers.parseWith
-- dflags1
-- fakeFileName
-- GHC.parseModule
-- inputStr
-- case parseResult of
-- Left (_, s) -> Left $ "parsing error: " ++ s
-- Right (anns, parsedModule) -> do
-- let (out, errs) = runIdentity
-- $ runMultiRWSTNil
-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW
-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW
-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns
-- $ ppModule parsedModule
-- if (not $ null errs)
-- then do
-- let errStrs = errs <&> \case
-- ErrorUnusedComment str -> str
-- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- else return $ TextL.toStrict $ Text.Builder.toLazyText out
_sigHead :: Sig GhcPs -> String
_sigHead = \case
TypeSig _ names _ ->
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
_ -> "unknown sig"
_bindHead :: HsBind GhcPs -> String
_bindHead = \case
FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind"