Refactor file/module structure again again
parent
b3f8317e99
commit
03e578f72c
|
|
@ -126,6 +126,9 @@ library
|
|||
Language.Haskell.Brittany.Internal.Config.Types
|
||||
Language.Haskell.Brittany.Internal.Config.Types.Instances1
|
||||
Language.Haskell.Brittany.Internal.Config.Types.Instances2
|
||||
Language.Haskell.Brittany.Internal.ParseExact
|
||||
Language.Haskell.Brittany.Internal.SplitExactModule
|
||||
Language.Haskell.Brittany.Internal.ToBriDoc.Comment
|
||||
Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl
|
||||
Language.Haskell.Brittany.Internal.ToBriDoc.Decl
|
||||
Language.Haskell.Brittany.Internal.ToBriDoc.Expr
|
||||
|
|
@ -140,11 +143,10 @@ library
|
|||
Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
Language.Haskell.Brittany.Internal.Components.Obfuscation
|
||||
Language.Haskell.Brittany.Internal.Components.OpTree
|
||||
Language.Haskell.Brittany.Internal.S1_Parsing
|
||||
Language.Haskell.Brittany.Internal.S2_SplitModule
|
||||
Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
Language.Haskell.Brittany.Internal.S4_WriteBriDoc
|
||||
Language.Haskell.Brittany.Internal.StepOrchestrate
|
||||
Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
Language.Haskell.Brittany.Internal.WriteBriDoc
|
||||
Language.Haskell.Brittany.Internal.PerModule
|
||||
Language.Haskell.Brittany.Internal.PerDecl
|
||||
Language.Haskell.Brittany.Internal.Prelude
|
||||
Language.Haskell.Brittany.Internal.Transformations.T1_Alt
|
||||
Language.Haskell.Brittany.Internal.Transformations.T2_Floating
|
||||
|
|
@ -156,7 +158,6 @@ library
|
|||
Language.Haskell.Brittany.Internal.WriteBriDoc.Types
|
||||
Language.Haskell.Brittany.Internal.Types
|
||||
Language.Haskell.Brittany.Internal.Utils
|
||||
Language.Haskell.Brittany.Internal.Util.AST
|
||||
Paths_brittany
|
||||
|
||||
executable brittany
|
||||
|
|
|
|||
|
|
@ -12,27 +12,36 @@ module Language.Haskell.Brittany.Internal
|
|||
, 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.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import qualified Language.Haskell.Brittany.Internal.S1_Parsing
|
||||
import qualified Language.Haskell.Brittany.Internal.ParseExact
|
||||
as Parsing
|
||||
import qualified Language.Haskell.Brittany.Internal.S2_SplitModule
|
||||
import qualified Language.Haskell.Brittany.Internal.SplitExactModule
|
||||
as Splitting
|
||||
import Language.Haskell.Brittany.Internal.StepOrchestrate
|
||||
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
|
||||
|
|
@ -40,6 +49,162 @@ 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.
|
||||
|
|
@ -56,84 +221,12 @@ parsePrintModule
|
|||
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
|
||||
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
|
||||
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 moduleElementList
|
||||
else lift $ pPrintModuleAndCheck traceFunc
|
||||
moduleConfig
|
||||
perItemConf
|
||||
moduleElementList
|
||||
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
|
||||
|
||||
(_errsWarns, output, _) <- ExceptT $ liftIO $ parsePrintModuleCommon
|
||||
traceFunc
|
||||
config
|
||||
(Right $ Text.unpack inputText)
|
||||
(pure ())
|
||||
pure output
|
||||
|
||||
|
||||
-- | Additionally checks that the output compiles again, appending an error
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.S1_Parsing
|
||||
module Language.Haskell.Brittany.Internal.ParseExact
|
||||
( parseModule
|
||||
, parseModuleFromString
|
||||
)
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.PerDecl
|
||||
( ppToplevelDecl
|
||||
) where
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
|
||||
import qualified GHC
|
||||
import GHC ( EpaCommentTok
|
||||
, GenLocated(L)
|
||||
, LHsDecl
|
||||
, SrcSpanAnn'(SrcSpanAnn)
|
||||
)
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Config.Types.Instances2
|
||||
( )
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.WriteBriDoc
|
||||
( ppBriDoc )
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Comment
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc
|
||||
( layouters )
|
||||
|
||||
|
||||
|
||||
ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal ()
|
||||
ppToplevelDecl decl immediateAfterComms = do
|
||||
exactprintOnly <- mAsk <&> \declConfig ->
|
||||
declConfig & _conf_roundtrip_exactprint_only & confUnpack
|
||||
bd <- fmap fst $ if exactprintOnly
|
||||
then briDocMToPPM layouters $ docSeq
|
||||
(briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
|
||||
else do
|
||||
let innerDoc = case decl of
|
||||
L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ ->
|
||||
docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl
|
||||
_ -> layoutDecl decl
|
||||
(r, errorCount) <- briDocMToPPM layouters $ docSeq
|
||||
(innerDoc : map commentToDoc immediateAfterComms)
|
||||
if errorCount == 0
|
||||
then pure (r, 0)
|
||||
else briDocMToPPM layouters $ briDocByExactNoComment decl
|
||||
ppBriDoc bd False
|
||||
let commCntIn = connectedCommentCount decl
|
||||
commCntOut <- mGet
|
||||
when (commCntIn /= commCntOut) $ if commCntOut < commCntIn
|
||||
then mTell
|
||||
[ ErrorUnusedComments decl
|
||||
(unCommentCounter commCntIn)
|
||||
(unCommentCounter commCntOut)
|
||||
]
|
||||
else mTell
|
||||
[ ErrorUnusedComments decl
|
||||
(unCommentCounter commCntIn)
|
||||
(unCommentCounter commCntOut)
|
||||
]
|
||||
-- error
|
||||
-- $ "internal brittany error: inconsistent comment count ("
|
||||
-- ++ show commCntOut
|
||||
-- ++ ">"
|
||||
-- ++ show commCntIn
|
||||
-- ++ ")!"
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.StepOrchestrate
|
||||
module Language.Haskell.Brittany.Internal.PerModule
|
||||
( processModule
|
||||
) where
|
||||
|
||||
|
|
@ -24,7 +24,6 @@ import GHC ( EpaComment(EpaComment)
|
|||
, GenLocated(L)
|
||||
, HsModule(HsModule)
|
||||
, LHsDecl
|
||||
, SrcSpanAnn'(SrcSpanAnn)
|
||||
)
|
||||
import qualified GHC.Types.SrcLoc as GHC
|
||||
import qualified GHC.OldList as List
|
||||
|
|
@ -36,19 +35,23 @@ import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Config.Types.Instances2
|
||||
( )
|
||||
import Language.Haskell.Brittany.Internal.S2_SplitModule
|
||||
( splitModuleStart )
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.S4_WriteBriDoc
|
||||
import Language.Haskell.Brittany.Internal.SplitExactModule
|
||||
( getDeclBindingNames
|
||||
, splitModuleStart
|
||||
)
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.WriteBriDoc
|
||||
( ppBriDoc )
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Comment
|
||||
( commentToDoc )
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Import
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Module
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Util.AST
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc
|
||||
( layouters )
|
||||
import Language.Haskell.Brittany.Internal.PerDecl
|
||||
( ppToplevelDecl )
|
||||
|
||||
|
||||
|
||||
|
|
@ -182,21 +185,6 @@ processModule traceFunc conf inlineConf moduleElems = do
|
|||
-- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp)
|
||||
ppmMoveToExactLoc dp
|
||||
|
||||
commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
|
||||
commentToDoc (indent, c) = case c of
|
||||
GHC.EpaDocCommentNext str -> handle str
|
||||
GHC.EpaDocCommentPrev str -> handle str
|
||||
GHC.EpaDocCommentNamed str -> handle str
|
||||
GHC.EpaDocSection _ str -> handle str
|
||||
GHC.EpaDocOptions str -> handle str
|
||||
GHC.EpaLineComment str -> handle str
|
||||
GHC.EpaBlockComment str -> handle str
|
||||
GHC.EpaEofComment -> docEmpty
|
||||
where
|
||||
handle str = if indent == 0
|
||||
then docLitS str
|
||||
else docSeq [docSeparator, docLitS $ (replicate (indent - 1) ' ') ++ str ]
|
||||
|
||||
-- Prints the information associated with the module annotation
|
||||
-- This includes the imports
|
||||
-- This returns a `Maybe` because it only produces a BriDocNumbered if
|
||||
|
|
@ -234,41 +222,4 @@ getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
|
|||
GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf
|
||||
GHC.UnhelpfulSpan{} -> Nothing
|
||||
|
||||
ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal ()
|
||||
ppToplevelDecl decl immediateAfterComms = do
|
||||
exactprintOnly <- mAsk <&> \declConfig ->
|
||||
declConfig & _conf_roundtrip_exactprint_only & confUnpack
|
||||
bd <- fmap fst $ if exactprintOnly
|
||||
then briDocMToPPM layouters $ docSeq
|
||||
(briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
|
||||
else do
|
||||
let innerDoc = case decl of
|
||||
L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ ->
|
||||
docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl
|
||||
_ -> layoutDecl decl
|
||||
(r, errorCount) <- briDocMToPPM layouters $ docSeq
|
||||
(innerDoc : map commentToDoc immediateAfterComms)
|
||||
if errorCount == 0
|
||||
then pure (r, 0)
|
||||
else briDocMToPPM layouters $ briDocByExactNoComment decl
|
||||
ppBriDoc bd False
|
||||
let commCntIn = connectedCommentCount decl
|
||||
commCntOut <- mGet
|
||||
when (commCntIn /= commCntOut) $ if commCntOut < commCntIn
|
||||
then mTell
|
||||
[ ErrorUnusedComments decl
|
||||
(unCommentCounter commCntIn)
|
||||
(unCommentCounter commCntOut)
|
||||
]
|
||||
else mTell
|
||||
[ ErrorUnusedComments decl
|
||||
(unCommentCounter commCntIn)
|
||||
(unCommentCounter commCntOut)
|
||||
]
|
||||
-- error
|
||||
-- $ "internal brittany error: inconsistent comment count ("
|
||||
-- ++ show commCntOut
|
||||
-- ++ ">"
|
||||
-- ++ show commCntIn
|
||||
-- ++ ")!"
|
||||
|
||||
|
|
@ -189,7 +189,7 @@ import Prelude as E
|
|||
, undefined
|
||||
, (||)
|
||||
)
|
||||
import System.IO as E (IO, hFlush, stdout)
|
||||
import System.IO as E (IO, hFlush, stdout, FilePath)
|
||||
import Text.Read as E (readMaybe)
|
||||
|
||||
import qualified Data.Strict.Maybe as Strict
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||
-- TODO92
|
||||
|
||||
module Language.Haskell.Brittany.Internal.S2_SplitModule
|
||||
module Language.Haskell.Brittany.Internal.SplitExactModule
|
||||
( extractDeclMap
|
||||
, splitModuleDecls
|
||||
, splitModuleStart
|
||||
, getDeclBindingNames
|
||||
) where
|
||||
|
||||
|
||||
|
|
@ -15,6 +15,7 @@ import Language.Haskell.Brittany.Internal.Prelude
|
|||
import qualified Data.Generics as SYB
|
||||
import qualified Data.List.Extra
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import qualified GHC
|
||||
import GHC ( AddEpAnn(AddEpAnn)
|
||||
, Anchor(Anchor)
|
||||
|
|
@ -47,11 +48,21 @@ import GHC ( AddEpAnn(AddEpAnn)
|
|||
, SrcSpanAnn'(SrcSpanAnn)
|
||||
, anchor
|
||||
, ideclName
|
||||
, moduleName
|
||||
, moduleNameString
|
||||
, srcLocCol
|
||||
, srcLocLine
|
||||
, unLoc
|
||||
)
|
||||
import GHC.Types.Name ( getOccString )
|
||||
import GHC.Types.Name.Occurrence ( occNameString )
|
||||
import GHC.Types.Name.Reader ( RdrName
|
||||
( Exact
|
||||
, Orig
|
||||
, Qual
|
||||
, Unqual
|
||||
)
|
||||
)
|
||||
import qualified GHC.OldList as List
|
||||
import GHC.Parser.Annotation ( DeltaPos
|
||||
( DifferentLine
|
||||
|
|
@ -73,7 +84,6 @@ import qualified Control.Monad.Trans.Writer.Strict
|
|||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Module
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Util.AST
|
||||
|
||||
|
||||
|
||||
|
|
@ -427,3 +437,19 @@ sortCommentedImports =
|
|||
(l@SamelineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest
|
||||
(ImportStatement r : rest) -> go (r : acc) rest
|
||||
[] -> [Right (reverse acc)]
|
||||
|
||||
rdrNameToText :: RdrName -> Text
|
||||
-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
|
||||
rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
|
||||
rdrNameToText (Qual mname occname) =
|
||||
Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
|
||||
rdrNameToText (Orig modul occname) =
|
||||
Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
|
||||
rdrNameToText (Exact name) = Text.pack $ getOccString name
|
||||
|
||||
getDeclBindingNames :: GHC.LHsDecl GhcPs -> [String]
|
||||
getDeclBindingNames (L _ decl) = case decl of
|
||||
GHC.SigD _ (GHC.TypeSig _ ns _) ->
|
||||
ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
|
||||
GHC.ValD _ (GHC.FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
|
||||
_ -> []
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.ToBriDoc.Comment
|
||||
( commentToDoc
|
||||
) where
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
|
||||
import GHC ( EpaCommentTok
|
||||
( EpaBlockComment
|
||||
, EpaDocCommentNamed
|
||||
, EpaDocCommentNext
|
||||
, EpaDocCommentPrev
|
||||
, EpaDocOptions
|
||||
, EpaDocSection
|
||||
, EpaEofComment
|
||||
, EpaLineComment
|
||||
)
|
||||
)
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
|
||||
|
||||
|
||||
commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
|
||||
commentToDoc (indent, c) = case c of
|
||||
GHC.EpaDocCommentNext str -> handle str
|
||||
GHC.EpaDocCommentPrev str -> handle str
|
||||
GHC.EpaDocCommentNamed str -> handle str
|
||||
GHC.EpaDocSection _ str -> handle str
|
||||
GHC.EpaDocOptions str -> handle str
|
||||
GHC.EpaLineComment str -> handle str
|
||||
GHC.EpaBlockComment str -> handle str
|
||||
GHC.EpaEofComment -> docEmpty
|
||||
where
|
||||
handle str = if indent == 0
|
||||
then docLitS str
|
||||
else docSeq [docSeparator, docLitS $ (replicate (indent - 1) ' ') ++ str ]
|
||||
|
|
@ -7,7 +7,7 @@ import GHC (GenLocated(L))
|
|||
import GHC.Hs
|
||||
import qualified GHC.OldList as List
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ import GHC.Types.SrcLoc (Located, getLoc, unLoc)
|
|||
import qualified GHC
|
||||
import qualified GHC.Types.SrcLoc as GHC
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ import qualified GHC.Types.SrcLoc as GHC
|
|||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ import qualified Data.Data
|
|||
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ import GHC.Types.Basic
|
|||
import GHC.Types.SourceText(SourceText(SourceText, NoSourceText), sl_st)
|
||||
import GHC.Unit.Types (IsBootInterface(..))
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ import GHC.Hs
|
|||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|||
import Language.Haskell.Brittany.Internal.Components.OpTree
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import GHC (GenLocated(L), ol_val)
|
|||
import GHC.Hs
|
||||
import qualified GHC.OldList as List
|
||||
import GHC.Types.Basic
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ import qualified Data.Text as Text
|
|||
import GHC (GenLocated(L))
|
||||
import GHC.Hs
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ import GHC.Utils.Outputable (ftext, showSDocUnsafe)
|
|||
import GHC.Types.Fixity ( Fixity(Fixity)
|
||||
, FixityDirection(InfixN)
|
||||
)
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.S3_ToBriDocTools where
|
||||
module Language.Haskell.Brittany.Internal.ToBriDocTools where
|
||||
|
||||
import qualified Control.Monad.Writer.Strict as Writer
|
||||
import qualified Data.Char as Char
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.Util.AST where
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import GHC ( moduleName
|
||||
, moduleNameString
|
||||
, GenLocated(L)
|
||||
)
|
||||
import qualified GHC
|
||||
import GHC.Types.Name ( getOccString )
|
||||
import GHC.Types.Name.Occurrence ( occNameString
|
||||
)
|
||||
import GHC.Types.Name.Reader ( RdrName
|
||||
( Exact
|
||||
, Orig
|
||||
, Qual
|
||||
, Unqual
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
rdrNameToText :: RdrName -> Text
|
||||
-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
|
||||
rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
|
||||
rdrNameToText (Qual mname occname) =
|
||||
Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
|
||||
rdrNameToText (Orig modul occname) =
|
||||
Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
|
||||
rdrNameToText (Exact name) = Text.pack $ getOccString name
|
||||
|
||||
getDeclBindingNames :: GHC.LHsDecl GhcPs -> [String]
|
||||
getDeclBindingNames (L _ decl) = case decl of
|
||||
GHC.SigD _ (GHC.TypeSig _ ns _) ->
|
||||
ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
|
||||
GHC.ValD _ (GHC.FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
|
||||
_ -> []
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.S4_WriteBriDoc
|
||||
module Language.Haskell.Brittany.Internal.WriteBriDoc
|
||||
( ppBriDoc
|
||||
)
|
||||
where
|
||||
|
|
@ -6,28 +6,20 @@ module Language.Haskell.Brittany.Main where
|
|||
|
||||
import Control.Monad (zipWithM)
|
||||
import qualified Control.Monad.Trans.Except as ExceptT
|
||||
import Data.CZipWith
|
||||
import qualified Data.Either
|
||||
import qualified Data.List.Extra
|
||||
import qualified Data.Monoid
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as Text.IO
|
||||
import qualified Data.Text.Lazy as TextL
|
||||
import DataTreePrint
|
||||
import GHC (GenLocated(L))
|
||||
import qualified GHC
|
||||
import qualified GHC.Driver.Session as GHC
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
import qualified GHC.OldList as List
|
||||
import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)
|
||||
import Language.Haskell.Brittany.Internal
|
||||
import Language.Haskell.Brittany.Internal.Config.Config
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Components.Obfuscation
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import Paths_brittany
|
||||
import qualified System.Directory as Directory
|
||||
import qualified System.Environment as Environment
|
||||
|
|
@ -309,135 +301,14 @@ coreIO
|
|||
coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
|
||||
ExceptT.runExceptT $ do
|
||||
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
|
||||
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
|
||||
-- there is a good of code duplication between the following code and the
|
||||
-- `pureModuleTransform` function. Unfortunately, there are also a good
|
||||
-- amount of slight differences: This module is a bit more verbose, and
|
||||
-- it tries to use the full-blown `parseModule` function which supports
|
||||
-- CPP (but requires the input to be a file..).
|
||||
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
|
||||
-- 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.
|
||||
let
|
||||
hackAroundIncludes =
|
||||
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
|
||||
let
|
||||
exactprintOnly = viaGlobal || viaDebug
|
||||
where
|
||||
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
|
||||
viaDebug =
|
||||
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
|
||||
|
||||
let
|
||||
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
|
||||
then case cppMode of
|
||||
CPPModeAbort -> do
|
||||
return $ Left "Encountered -XCPP. Aborting."
|
||||
CPPModeWarn -> do
|
||||
putErrorLnIO
|
||||
$ "Warning: Encountered -XCPP."
|
||||
++ " Be warned that -XCPP is not supported and that"
|
||||
++ " brittany cannot check that its output is syntactically"
|
||||
++ " valid in its presence."
|
||||
return $ Right True
|
||||
CPPModeNowarn -> return $ Right True
|
||||
else return $ Right False
|
||||
(parseResult, originalContents) <- case inputPathM of
|
||||
inputVal <- case inputPathM of
|
||||
Nothing -> do
|
||||
-- TODO: refactor this hack to not be mixed into parsing logic
|
||||
let
|
||||
hackF s = if "#include" `isPrefixOf` s
|
||||
then "-- BRITANY_INCLUDE_HACK " ++ s
|
||||
else s
|
||||
let
|
||||
hackTransform = if hackAroundIncludes && not exactprintOnly
|
||||
then List.intercalate "\n" . fmap hackF . lines'
|
||||
else id
|
||||
inputString <- liftIO System.IO.getContents
|
||||
parseRes <- liftIO $ parseModuleFromString
|
||||
ghcOptions
|
||||
"stdin"
|
||||
cppCheckFunc
|
||||
(hackTransform inputString)
|
||||
return (parseRes, Text.pack inputString)
|
||||
Just p -> liftIO $ do
|
||||
parseRes <- parseModule ghcOptions p cppCheckFunc
|
||||
inputText <- 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.)
|
||||
return (parseRes, inputText)
|
||||
case parseResult of
|
||||
Left left -> do
|
||||
putErrorLn "parse error:"
|
||||
putErrorLn left
|
||||
ExceptT.throwE 60
|
||||
Right (parsedSource, hasCPP) -> do
|
||||
let moduleElementList = splitModuleDecls parsedSource
|
||||
(inlineConf, perItemConf) <- do
|
||||
resE <-
|
||||
liftIO
|
||||
$ ExceptT.runExceptT
|
||||
$ extractCommentConfigs
|
||||
putErrorLnIO
|
||||
(extractDeclMap parsedSource)
|
||||
moduleElementList
|
||||
case resE of
|
||||
Left (err, input) -> do
|
||||
putErrorLn $ "Error: parse error in inline configuration:"
|
||||
putErrorLn err
|
||||
putErrorLn $ " in the string \"" ++ input ++ "\"."
|
||||
ExceptT.throwE 61
|
||||
Right c -> -- trace (showTree c) $
|
||||
pure c
|
||||
let moduleConf = cZipWith fromOptionIdentity config inlineConf
|
||||
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
|
||||
let val = printTreeWithCustom 160 customLayouterF parsedSource
|
||||
putErrorLn ("---- ast ----\n" ++ show val)
|
||||
let
|
||||
disableFormatting =
|
||||
moduleConf & _conf_disable_formatting & confUnpack
|
||||
(errsWarns, outSText, hasChanges) <- do
|
||||
if
|
||||
| disableFormatting -> do
|
||||
pure ([], originalContents, False)
|
||||
| exactprintOnly -> do
|
||||
let r = Text.pack $ ExactPrint.exactPrint parsedSource
|
||||
pure ([], r, r /= originalContents)
|
||||
| otherwise -> do
|
||||
let
|
||||
omitCheck =
|
||||
moduleConf
|
||||
& _conf_errorHandling
|
||||
.> _econf_omit_output_valid_check
|
||||
.> confUnpack
|
||||
(ews, outRaw) <- if hasCPP || omitCheck
|
||||
then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
|
||||
else liftIO
|
||||
$ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
|
||||
let
|
||||
hackF s = fromMaybe s $ TextL.stripPrefix
|
||||
(TextL.pack "-- BRITANY_INCLUDE_HACK ")
|
||||
s
|
||||
let
|
||||
out = TextL.toStrict $ if hackAroundIncludes
|
||||
then
|
||||
TextL.intercalate (TextL.pack "\n")
|
||||
$ hackF
|
||||
<$> TextL.splitOn (TextL.pack "\n") outRaw
|
||||
else outRaw
|
||||
out' <- if moduleConf & _conf_obfuscate & confUnpack
|
||||
then lift $ obfuscate out
|
||||
else pure out
|
||||
pure $ (ews, out', out' /= originalContents)
|
||||
pure $ Right inputString
|
||||
Just p -> pure $ Left p
|
||||
let
|
||||
printErrorsAndWarnings errsWarns = do
|
||||
let
|
||||
customErrOrder ErrorInput{} = 4
|
||||
customErrOrder LayoutWarning{} = -1 :: Int
|
||||
|
|
@ -507,23 +378,35 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
|
|||
putErrorLn err
|
||||
putErrorLn $ " in the string \"" ++ input ++ "\"."
|
||||
[] -> error "cannot happen"
|
||||
parseResult <- liftIO $ parsePrintModuleCommon
|
||||
(TraceFunc putErrorLnIO)
|
||||
config
|
||||
inputVal
|
||||
( putErrorLnIO
|
||||
$ "Warning: Encountered -XCPP."
|
||||
++ " Be warned that -XCPP is not supported and that"
|
||||
++ " brittany cannot check that its output is syntactically"
|
||||
++ " valid in its presence."
|
||||
)
|
||||
|
||||
case parseResult of
|
||||
Left errWarns@[ErrorInput{}] -> do
|
||||
printErrorsAndWarnings errWarns
|
||||
ExceptT.throwE 60
|
||||
Left errWarns@(ErrorMacroConfig{}: _) -> do
|
||||
printErrorsAndWarnings errWarns
|
||||
ExceptT.throwE 61
|
||||
Left errWarns -> do
|
||||
printErrorsAndWarnings errWarns
|
||||
ExceptT.throwE 70
|
||||
Right (errsWarns, outSText, hasChangesAct) -> do
|
||||
printErrorsAndWarnings errsWarns
|
||||
|
||||
hasChanges <- liftIO $ hasChangesAct
|
||||
|
||||
-- TODO: don't output anything when there are errors unless user
|
||||
-- adds some override?
|
||||
let
|
||||
hasErrors =
|
||||
if config & _conf_errorHandling & _econf_Werror & confUnpack
|
||||
then not $ null errsWarns
|
||||
else 0 < maximum (-1 : fmap customErrOrder errsWarns)
|
||||
outputOnErrs =
|
||||
config
|
||||
& _conf_errorHandling
|
||||
& _econf_produceOutputOnErrors
|
||||
& confUnpack
|
||||
shouldOutput =
|
||||
not suppressOutput
|
||||
&& not checkMode
|
||||
&& (not hasErrors || outputOnErrs)
|
||||
|
||||
let shouldOutput = not suppressOutput && not checkMode
|
||||
when shouldOutput
|
||||
$ addTraceSep (_conf_debug config)
|
||||
$ case outputPathM of
|
||||
|
|
@ -539,7 +422,6 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
|
|||
Nothing -> pure ()
|
||||
Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p
|
||||
|
||||
when hasErrors $ ExceptT.throwE 70
|
||||
return (if hasChanges then Changes else NoChanges)
|
||||
where
|
||||
addTraceSep conf =
|
||||
|
|
|
|||
Loading…
Reference in New Issue