354 lines
14 KiB
Haskell
354 lines
14 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal
|
|
( Parsing.parseModule
|
|
, Parsing.parseModuleFromString
|
|
, parsePrintModule
|
|
, parsePrintModuleTests
|
|
, processModule
|
|
, pPrintModuleAndCheck
|
|
-- re-export from utils:
|
|
, extractCommentConfigs
|
|
, TraceFunc(TraceFunc)
|
|
, Splitting.splitModuleDecls
|
|
, Splitting.extractDeclMap
|
|
, applyCPPTransformIfEnabledPre
|
|
, applyCPPTransformIfEnabledPost
|
|
, parsePrintModuleCommon
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Trans.Except
|
|
import DataTreePrint ( printTreeWithCustom )
|
|
import Data.CZipWith
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as TextL
|
|
import qualified Data.Text.IO as Text.IO
|
|
import qualified GHC.Driver.Session as GHC
|
|
import GHC.Hs
|
|
import qualified GHC.LanguageExtensions.Type as GHC
|
|
import qualified Language.Haskell.GHC.ExactPrint
|
|
as ExactPrint
|
|
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.ToBriDocTools
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import qualified Language.Haskell.Brittany.Internal.ParseExact
|
|
as Parsing
|
|
import qualified Language.Haskell.Brittany.Internal.SplitExactModule
|
|
as Splitting
|
|
import Language.Haskell.Brittany.Internal.Components.Obfuscation
|
|
( obfuscate )
|
|
import Language.Haskell.Brittany.Internal.PerModule
|
|
( processModule )
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
|
|
|
|
|
|
|
|
applyCPPTransformIfEnabledPre :: Config -> String -> String
|
|
applyCPPTransformIfEnabledPre config =
|
|
if hackAroundIncludes && not exactprintOnly
|
|
then List.intercalate "\n" . fmap hackF . lines'
|
|
else id
|
|
where
|
|
-- the flag will do the following: insert a marker string
|
|
-- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
|
|
-- "#include" before processing (parsing) input; and remove that marker
|
|
-- string from the transformation output.
|
|
-- The flag is intentionally misspelled to prevent clashing with
|
|
-- inline-config stuff.
|
|
hackAroundIncludes =
|
|
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
|
|
exactprintOnly = viaGlobal || viaDebug
|
|
where
|
|
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
|
|
viaDebug =
|
|
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
|
|
hackF s = if "#include" `isPrefixOf` s
|
|
then "-- BRITANY_INCLUDE_HACK " ++ s
|
|
else s
|
|
|
|
applyCPPTransformIfEnabledPost :: Config -> TextL.Text -> TextL.Text
|
|
applyCPPTransformIfEnabledPost config =
|
|
if hackAroundIncludes && not exactprintOnly
|
|
then
|
|
TextL.intercalate (TextL.pack "\n")
|
|
. map hackF
|
|
. TextL.splitOn (TextL.pack "\n")
|
|
else id
|
|
where
|
|
hackAroundIncludes =
|
|
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
|
|
exactprintOnly = viaGlobal || viaDebug
|
|
where
|
|
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
|
|
viaDebug =
|
|
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
|
|
hackF s = fromMaybe s
|
|
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
|
|
|
|
parsePrintModuleCommon
|
|
:: TraceFunc
|
|
-> Config
|
|
-> Either FilePath String
|
|
-> IO ()
|
|
-> IO (Either [BrittanyError] ([BrittanyError], Text, IO Bool))
|
|
parsePrintModuleCommon traceFunc config inputE cppWarnAction = runExceptT $ do
|
|
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
|
|
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
|
|
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
|
|
then case cppMode of
|
|
CPPModeAbort -> pure $ Left "Encountered -XCPP. Aborting."
|
|
CPPModeWarn -> cppWarnAction $> Right True
|
|
CPPModeNowarn -> pure $ Right True
|
|
else pure $ Right False
|
|
(parseResult, originalContentAct) <- case inputE of
|
|
Left p -> liftIO $ do
|
|
parseRes <- Parsing.parseModule ghcOptions p cppCheckFunc
|
|
pure (parseRes, Text.IO.readFile p)
|
|
-- The above means we read the file twice, but the
|
|
-- GHC API does not really expose the source it
|
|
-- read. Should be in cache still anyways.
|
|
--
|
|
-- We do not use TextL.IO.readFile because lazy IO is evil.
|
|
-- (not identical -> read is not finished ->
|
|
-- handle still open -> write below crashes - evil.)
|
|
Right inputString -> do
|
|
parseRes <- liftIO
|
|
$ Parsing.parseModuleFromString
|
|
ghcOptions
|
|
"stdin"
|
|
cppCheckFunc
|
|
(applyCPPTransformIfEnabledPre config inputString)
|
|
pure (parseRes, pure $ Text.pack inputString)
|
|
(parsedSource, hasCPP) <- case parseResult of
|
|
Left err -> throwE [ErrorInput err]
|
|
Right x -> pure x
|
|
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
|
|
let val = printTreeWithCustom 160 customLayouterF parsedSource
|
|
liftIO $ useTraceFunc traceFunc ("---- ast ----\n" ++ show val)
|
|
let moduleElementList = Splitting.splitModuleDecls parsedSource
|
|
(inlineConf, perItemConf) <-
|
|
mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
|
|
$ extractCommentConfigs (useTraceFunc traceFunc)
|
|
(Splitting.extractDeclMap parsedSource)
|
|
moduleElementList
|
|
let moduleConfig = cZipWith fromOptionIdentity config inlineConf
|
|
let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
|
|
let exactprintOnly = viaGlobal || viaDebug
|
|
where
|
|
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
|
|
viaDebug =
|
|
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
|
|
let omitCheck =
|
|
moduleConfig
|
|
& _conf_errorHandling
|
|
& _econf_omit_output_valid_check
|
|
& confUnpack
|
|
if
|
|
| disableFormatting -> do
|
|
originalContents <- liftIO $ originalContentAct
|
|
pure ([], originalContents, pure False)
|
|
| exactprintOnly -> do
|
|
let r = Text.pack $ ExactPrint.exactPrint parsedSource
|
|
pure
|
|
( []
|
|
, r
|
|
, do
|
|
originalContents <- originalContentAct
|
|
pure $ originalContents /= r
|
|
)
|
|
| otherwise -> do
|
|
let
|
|
applyObfuscateIfEnabled =
|
|
if moduleConfig & _conf_obfuscate & confUnpack
|
|
then lift . obfuscate
|
|
else pure
|
|
(errsWarns, outRaw) <- if hasCPP || omitCheck
|
|
then lift
|
|
$ processModule traceFunc moduleConfig perItemConf moduleElementList
|
|
else lift
|
|
$ pPrintModuleAndCheck traceFunc
|
|
moduleConfig
|
|
perItemConf
|
|
moduleElementList
|
|
outputText <- applyObfuscateIfEnabled
|
|
(TextL.toStrict $ applyCPPTransformIfEnabledPost config outRaw)
|
|
let
|
|
hasErrors = \case
|
|
ErrorInput{} -> True
|
|
LayoutWarning{} ->
|
|
moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
|
|
ErrorOutputCheck{} -> True
|
|
ErrorUnusedComment{} -> True
|
|
ErrorUnusedComments{} -> True
|
|
ErrorUnknownNode{} -> True
|
|
ErrorMacroConfig{} -> True
|
|
outputOnErrs =
|
|
config
|
|
& _conf_errorHandling
|
|
& _econf_produceOutputOnErrors
|
|
& confUnpack
|
|
if any hasErrors errsWarns && not outputOnErrs
|
|
then throwE $ errsWarns
|
|
else pure
|
|
$ ( errsWarns
|
|
, outputText
|
|
, do
|
|
originalContents <- liftIO $ originalContentAct
|
|
pure $ originalContents /= outputText
|
|
)
|
|
|
|
-- pure $ _ (parsed, hasCPP, originalContentAct)
|
|
|
|
-- | 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 }
|
|
(_errsWarns, output, _) <- ExceptT $ liftIO $ parsePrintModuleCommon
|
|
traceFunc
|
|
config
|
|
(Right $ Text.unpack inputText)
|
|
(pure ())
|
|
pure output
|
|
|
|
|
|
-- | Additionally checks that the output compiles again, appending an error
|
|
-- if it does not.
|
|
pPrintModuleAndCheck
|
|
:: TraceFunc
|
|
-> Config
|
|
-> PerItemConfig
|
|
-> FinalList ModuleElement p
|
|
-> IO ([BrittanyError], TextL.Text)
|
|
pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do
|
|
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
|
|
(errs, output) <- processModule traceFunc conf inlineConf moduleElementList
|
|
parseResult <- Parsing.parseModuleFromString ghcOptions
|
|
"output"
|
|
(\_ -> return $ Right ())
|
|
(TextL.unpack output)
|
|
let errs' = errs ++ case parseResult of
|
|
Left x -> [ErrorOutputCheck x]
|
|
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
|
|
let moduleElementList = Splitting.splitModuleDecls parsedModule
|
|
(inlineConf, perItemConf) <-
|
|
mapExceptT
|
|
(fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id))
|
|
$ extractCommentConfigs
|
|
(\_ -> pure ())
|
|
(Splitting.extractDeclMap parsedModule)
|
|
moduleElementList
|
|
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
|
|
moduleElementList
|
|
else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
|
|
moduleConf
|
|
perItemConf
|
|
moduleElementList
|
|
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 str -> "Output is not syntactically valid: " ++ str
|
|
-- 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"
|
|
|
|
|
|
|