685 lines
24 KiB
Haskell
685 lines
24 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Language.Haskell.Brittany.Internal
|
|
( parsePrintModule
|
|
, parsePrintModuleTests
|
|
, pPrintModule
|
|
, pPrintModuleAndCheck
|
|
-- re-export from utils:
|
|
, parseModule
|
|
, parseModuleFromString
|
|
, extractCommentConfigs
|
|
, getTopLevelDeclNameMap
|
|
) where
|
|
|
|
import Control.Monad.Trans.Except
|
|
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
|
|
import qualified Data.ByteString.Char8
|
|
import Data.CZipWith
|
|
import Data.Char (isSpace)
|
|
import Data.HList.HList
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Maybe
|
|
import qualified Data.Semigroup as Semigroup
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as TextL
|
|
import qualified Data.Text.Lazy.Builder as Text.Builder
|
|
import qualified Data.Yaml
|
|
import qualified GHC hiding (parseModule)
|
|
import GHC (GenLocated(L))
|
|
import qualified GHC.Driver.Session as GHC
|
|
import GHC.Hs
|
|
import qualified GHC.LanguageExtensions.Type as GHC
|
|
import qualified GHC.OldList as List
|
|
import GHC.Parser.Annotation (AnnKeywordId(..))
|
|
import GHC.Types.SrcLoc (SrcSpan)
|
|
import Language.Haskell.Brittany.Internal.Backend
|
|
import Language.Haskell.Brittany.Internal.BackendUtils
|
|
import Language.Haskell.Brittany.Internal.Config
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.ExactPrintUtils
|
|
import Language.Haskell.Brittany.Internal.LayouterBasics
|
|
import Language.Haskell.Brittany.Internal.Layouters.Decl
|
|
import Language.Haskell.Brittany.Internal.Layouters.Module
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import Language.Haskell.Brittany.Internal.PreludeUtils
|
|
import Language.Haskell.Brittany.Internal.Transformations.Alt
|
|
import Language.Haskell.Brittany.Internal.Transformations.Columns
|
|
import Language.Haskell.Brittany.Internal.Transformations.Floating
|
|
import Language.Haskell.Brittany.Internal.Transformations.Indent
|
|
import Language.Haskell.Brittany.Internal.Transformations.Par
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
|
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
|
import qualified UI.Butcher.Monadic as Butcher
|
|
|
|
|
|
|
|
data InlineConfigTarget
|
|
= InlineConfigTargetModule
|
|
| InlineConfigTargetNextDecl -- really only next in module
|
|
| InlineConfigTargetNextBinding -- by name
|
|
| InlineConfigTargetBinding String
|
|
|
|
extractCommentConfigs
|
|
:: ExactPrint.Anns
|
|
-> TopLevelDeclNameMap
|
|
-> Either (String, String) (CConfig Maybe, PerItemConfig)
|
|
extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
|
|
let
|
|
commentLiness =
|
|
[ ( k
|
|
, [ x
|
|
| (ExactPrint.Comment x _ _, _) <-
|
|
(ExactPrint.annPriorComments ann
|
|
++ ExactPrint.annFollowingComments ann
|
|
)
|
|
]
|
|
++ [ x
|
|
| (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
|
|
ExactPrint.annsDP ann
|
|
]
|
|
)
|
|
| (k, ann) <- Map.toList anns
|
|
]
|
|
let
|
|
configLiness = commentLiness <&> second
|
|
(Data.Maybe.mapMaybe $ \line -> do
|
|
l1 <-
|
|
List.stripPrefix "-- BRITTANY" line
|
|
<|> List.stripPrefix "--BRITTANY" line
|
|
<|> List.stripPrefix "-- brittany" line
|
|
<|> List.stripPrefix "--brittany" line
|
|
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
|
|
let l2 = dropWhile isSpace l1
|
|
guard
|
|
(("@" `isPrefixOf` l2)
|
|
|| ("-disable" `isPrefixOf` l2)
|
|
|| ("-next" `isPrefixOf` l2)
|
|
|| ("{" `isPrefixOf` l2)
|
|
|| ("--" `isPrefixOf` l2)
|
|
)
|
|
pure l2
|
|
)
|
|
let
|
|
configParser = Butcher.addAlternatives
|
|
[ ( "commandline-config"
|
|
, \s -> "-" `isPrefixOf` dropWhile (== ' ') s
|
|
, cmdlineConfigParser
|
|
)
|
|
, ( "yaml-config-document"
|
|
, \s -> "{" `isPrefixOf` dropWhile (== ' ') s
|
|
, Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")
|
|
$ fmap (\lconf -> (mempty { _conf_layout = lconf }, ""))
|
|
. either (const Nothing) Just
|
|
. Data.Yaml.decodeEither'
|
|
. Data.ByteString.Char8.pack
|
|
-- TODO: use some proper utf8 encoder instead?
|
|
)
|
|
]
|
|
parser = do -- we will (mis?)use butcher here to parse the inline config
|
|
-- line.
|
|
let
|
|
nextDecl = do
|
|
conf <- configParser
|
|
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
|
|
Butcher.addCmd "-next-declaration" nextDecl
|
|
Butcher.addCmd "-Next-Declaration" nextDecl
|
|
Butcher.addCmd "-NEXT-DECLARATION" nextDecl
|
|
let
|
|
nextBinding = do
|
|
conf <- configParser
|
|
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
|
|
Butcher.addCmd "-next-binding" nextBinding
|
|
Butcher.addCmd "-Next-Binding" nextBinding
|
|
Butcher.addCmd "-NEXT-BINDING" nextBinding
|
|
let
|
|
disableNextBinding = do
|
|
Butcher.addCmdImpl
|
|
( InlineConfigTargetNextBinding
|
|
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
|
|
)
|
|
Butcher.addCmd "-disable-next-binding" disableNextBinding
|
|
Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
|
|
Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
|
|
let
|
|
disableNextDecl = do
|
|
Butcher.addCmdImpl
|
|
( InlineConfigTargetNextDecl
|
|
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
|
|
)
|
|
Butcher.addCmd "-disable-next-declaration" disableNextDecl
|
|
Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
|
|
Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
|
|
let
|
|
disableFormatting = do
|
|
Butcher.addCmdImpl
|
|
( InlineConfigTargetModule
|
|
, mempty { _conf_disable_formatting = pure $ pure True }
|
|
)
|
|
Butcher.addCmd "-disable" disableFormatting
|
|
Butcher.addCmd "@" $ do
|
|
-- Butcher.addCmd "module" $ do
|
|
-- conf <- configParser
|
|
-- Butcher.addCmdImpl (InlineConfigTargetModule, conf)
|
|
Butcher.addNullCmd $ do
|
|
bindingName <- Butcher.addParamString "BINDING" mempty
|
|
conf <- configParser
|
|
Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)
|
|
conf <- configParser
|
|
Butcher.addCmdImpl (InlineConfigTargetModule, conf)
|
|
lineConfigss <- configLiness `forM` \(k, ss) -> do
|
|
r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of
|
|
Left err -> Left $ (err, s)
|
|
Right c -> Right $ c
|
|
pure (k, r)
|
|
|
|
let
|
|
perModule = foldl'
|
|
(<>)
|
|
mempty
|
|
[ conf
|
|
| (_, lineConfigs) <- lineConfigss
|
|
, (InlineConfigTargetModule, conf) <- lineConfigs
|
|
]
|
|
let
|
|
perBinding = Map.fromListWith
|
|
(<>)
|
|
[ (n, conf)
|
|
| (k, lineConfigs) <- lineConfigss
|
|
, (target, conf) <- lineConfigs
|
|
, n <- case target of
|
|
InlineConfigTargetBinding s -> [s]
|
|
InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
|
|
[name]
|
|
_ -> []
|
|
]
|
|
let
|
|
perKey = Map.fromListWith
|
|
(<>)
|
|
[ (k, conf)
|
|
| (k, lineConfigs) <- lineConfigss
|
|
, (target, conf) <- lineConfigs
|
|
, case target of
|
|
InlineConfigTargetNextDecl -> True
|
|
InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->
|
|
True
|
|
_ -> False
|
|
]
|
|
|
|
pure
|
|
$ ( perModule
|
|
, PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey }
|
|
)
|
|
|
|
|
|
getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
|
|
getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
|
|
TopLevelDeclNameMap $ Map.fromList
|
|
[ (ExactPrint.mkAnnKey decl, name)
|
|
| decl <- decls
|
|
, (name : _) <- [getDeclBindingNames decl]
|
|
]
|
|
|
|
|
|
-- | 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 :: Config -> Text -> IO (Either [BrittanyError] Text)
|
|
parsePrintModule 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
|
|
(anns, 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 $ parseModuleFromString
|
|
ghcOptions
|
|
"stdin"
|
|
cppCheckFunc
|
|
(hackTransform $ Text.unpack inputText)
|
|
case parseResult of
|
|
Left err -> throwE [ErrorInput err]
|
|
Right x -> pure x
|
|
(inlineConf, perItemConf) <-
|
|
either (throwE . (: []) . uncurry ErrorMacroConfig) pure
|
|
$ extractCommentConfigs anns (getTopLevelDeclNameMap 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 return $ pPrintModule moduleConfig perItemConf anns parsedSource
|
|
else lift
|
|
$ pPrintModuleAndCheck moduleConfig perItemConf anns 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{} = 4
|
|
customErrOrder LayoutWarning{} = 0 :: Int
|
|
customErrOrder ErrorOutputCheck{} = 1
|
|
customErrOrder ErrorUnusedComment{} = 2
|
|
customErrOrder ErrorUnknownNode{} = 3
|
|
customErrOrder ErrorMacroConfig{} = 5
|
|
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
|
|
|
|
|
|
|
|
-- BrittanyErrors can be non-fatal warnings, thus both are returned instead
|
|
-- of an Either.
|
|
-- This should be cleaned up once it is clear what kinds of errors really
|
|
-- can occur.
|
|
pPrintModule
|
|
:: Config
|
|
-> PerItemConfig
|
|
-> ExactPrint.Anns
|
|
-> GHC.ParsedSource
|
|
-> ([BrittanyError], TextL.Text)
|
|
pPrintModule conf inlineConf anns parsedModule =
|
|
let
|
|
((out, errs), debugStrings) =
|
|
runIdentity
|
|
$ MultiRWSS.runMultiRWSTNil
|
|
$ MultiRWSS.withMultiWriterAW
|
|
$ MultiRWSS.withMultiWriterAW
|
|
$ MultiRWSS.withMultiWriterW
|
|
$ MultiRWSS.withMultiReader anns
|
|
$ MultiRWSS.withMultiReader conf
|
|
$ MultiRWSS.withMultiReader inlineConf
|
|
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
|
|
$ do
|
|
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
|
|
$ annsDoc anns
|
|
ppModule parsedModule
|
|
tracer = if Seq.null debugStrings
|
|
then id
|
|
else
|
|
trace ("---- DEBUGMESSAGES ---- ")
|
|
. foldr (seq . join trace) id debugStrings
|
|
in tracer $ (errs, Text.Builder.toLazyText out)
|
|
-- unless () $ do
|
|
--
|
|
-- debugStrings `forM_` \s ->
|
|
-- trace s $ return ()
|
|
|
|
-- | Additionally checks that the output compiles again, appending an error
|
|
-- if it does not.
|
|
pPrintModuleAndCheck
|
|
:: Config
|
|
-> PerItemConfig
|
|
-> ExactPrint.Anns
|
|
-> GHC.ParsedSource
|
|
-> IO ([BrittanyError], TextL.Text)
|
|
pPrintModuleAndCheck conf inlineConf anns parsedModule = do
|
|
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
|
|
let (errs, output) = pPrintModule conf inlineConf anns parsedModule
|
|
parseResult <- 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 <- parseModuleFromString
|
|
(conf & _conf_forward & _options_ghc & runIdentity)
|
|
filename
|
|
(const . pure $ Right ())
|
|
inputStr
|
|
case parseResult of
|
|
Left err -> return $ Left err
|
|
Right (anns, parsedModule, _) -> runExceptT $ do
|
|
(inlineConf, perItemConf) <-
|
|
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
|
|
Left err -> throwE $ "error in inline config: " ++ show err
|
|
Right x -> pure x
|
|
let moduleConf = cZipWith fromOptionIdentity conf inlineConf
|
|
let
|
|
omitCheck =
|
|
conf
|
|
& _conf_errorHandling
|
|
.> _econf_omit_output_valid_check
|
|
.> confUnpack
|
|
(errs, ltext) <- if omitCheck
|
|
then return $ pPrintModule moduleConf perItemConf anns parsedModule
|
|
else lift
|
|
$ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
|
|
if null errs
|
|
then pure $ TextL.toStrict $ ltext
|
|
else
|
|
let
|
|
errStrs = errs <&> \case
|
|
ErrorInput str -> str
|
|
ErrorUnusedComment str -> str
|
|
LayoutWarning str -> str
|
|
ErrorUnknownNode str _ -> str
|
|
ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
|
|
ErrorOutputCheck -> "Output is not syntactically valid."
|
|
in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs
|
|
|
|
-- 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
|
|
|
|
toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a
|
|
toLocal conf anns m = do
|
|
(x, write) <-
|
|
lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m
|
|
MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)
|
|
pure x
|
|
|
|
ppModule :: GenLocated SrcSpan HsModule -> PPM ()
|
|
ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
|
|
defaultAnns <- do
|
|
anns <- mAsk
|
|
let annKey = ExactPrint.mkAnnKey lmod
|
|
let annMap = Map.findWithDefault Map.empty annKey anns
|
|
let isEof = (== ExactPrint.AnnEofPos)
|
|
let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a }
|
|
pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap
|
|
|
|
post <- ppPreamble lmod
|
|
decls `forM_` \decl -> do
|
|
let declAnnKey = ExactPrint.mkAnnKey decl
|
|
let declBindingNames = getDeclBindingNames decl
|
|
inlineConf <- mAsk
|
|
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
|
|
let
|
|
mBindingConfs =
|
|
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
|
|
filteredAnns <- mAsk <&> \annMap ->
|
|
Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap
|
|
|
|
traceIfDumpConf
|
|
"bridoc annotations filtered/transformed"
|
|
_dconf_dump_annotations
|
|
$ annsDoc filteredAnns
|
|
|
|
config <- mAsk
|
|
|
|
let
|
|
config' = cZipWith fromOptionIdentity config
|
|
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
|
|
|
|
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
|
|
toLocal config' filteredAnns $ do
|
|
bd <- if exactprintOnly
|
|
then briDocMToPPM $ briDocByExactNoComment decl
|
|
else do
|
|
(r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl
|
|
mTell debugs
|
|
mTell errs
|
|
if null errs
|
|
then pure r
|
|
else briDocMToPPM $ briDocByExactNoComment decl
|
|
layoutBriDoc bd
|
|
|
|
let
|
|
finalComments = filter
|
|
(fst .> \case
|
|
ExactPrint.AnnComment{} -> True
|
|
_ -> False
|
|
)
|
|
post
|
|
post `forM_` \case
|
|
(ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
|
|
ppmMoveToExactLoc l
|
|
mTell $ Text.Builder.fromString cmStr
|
|
(ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
|
|
let
|
|
folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
|
|
ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
|
|
( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
|
|
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
|
|
)
|
|
_ -> (acc + y, x)
|
|
(cmY, cmX) = foldl' folder (0, 0) finalComments
|
|
in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
|
|
_ -> return ()
|
|
|
|
getDeclBindingNames :: LHsDecl GhcPs -> [String]
|
|
getDeclBindingNames (L _ decl) = case decl of
|
|
SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
|
|
ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
|
|
_ -> []
|
|
|
|
|
|
-- Prints the information associated with the module annotation
|
|
-- This includes the imports
|
|
ppPreamble
|
|
:: GenLocated SrcSpan HsModule
|
|
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
|
|
ppPreamble lmod@(L loc m@HsModule{}) = do
|
|
filteredAnns <- mAsk <&> \annMap ->
|
|
Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
|
|
-- Since ghc-exactprint adds annotations following (implicit)
|
|
-- modules to both HsModule and the elements in the module
|
|
-- this can cause duplication of comments. So strip
|
|
-- attached annotations that come after the module's where
|
|
-- from the module node
|
|
config <- mAsk
|
|
let
|
|
shouldReformatPreamble =
|
|
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
|
|
|
|
let
|
|
(filteredAnns', post) =
|
|
case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of
|
|
Nothing -> (filteredAnns, [])
|
|
Just mAnn ->
|
|
let
|
|
modAnnsDp = ExactPrint.annsDP mAnn
|
|
isWhere (ExactPrint.G AnnWhere) = True
|
|
isWhere _ = False
|
|
isEof (ExactPrint.AnnEofPos) = True
|
|
isEof _ = False
|
|
whereInd = List.findIndex (isWhere . fst) modAnnsDp
|
|
eofInd = List.findIndex (isEof . fst) modAnnsDp
|
|
(pre, post') = case (whereInd, eofInd) of
|
|
(Nothing, Nothing) -> ([], modAnnsDp)
|
|
(Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp
|
|
(Nothing, Just _i) -> ([], modAnnsDp)
|
|
(Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp
|
|
mAnn' = mAnn { ExactPrint.annsDP = pre }
|
|
filteredAnns'' =
|
|
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
|
|
in (filteredAnns'', post')
|
|
traceIfDumpConf
|
|
"bridoc annotations filtered/transformed"
|
|
_dconf_dump_annotations
|
|
$ annsDoc filteredAnns'
|
|
|
|
if shouldReformatPreamble
|
|
then toLocal config filteredAnns' $ withTransformedAnns lmod $ do
|
|
briDoc <- briDocMToPPM $ layoutModule lmod
|
|
layoutBriDoc briDoc
|
|
else
|
|
let emptyModule = L loc m { hsmodDecls = [] }
|
|
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
|
|
return post
|
|
|
|
_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"
|
|
|
|
|
|
|
|
layoutBriDoc :: BriDocNumbered -> PPMLocal ()
|
|
layoutBriDoc briDoc = do
|
|
-- first step: transform the briDoc.
|
|
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
|
|
-- Note that briDoc is BriDocNumbered, but state type is BriDoc.
|
|
-- That's why the alt-transform looks a bit special here.
|
|
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
|
|
$ briDocToDoc
|
|
$ unwrapBriDocNumbered
|
|
$ briDoc
|
|
-- bridoc transformation: remove alts
|
|
transformAlts briDoc >>= mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
|
|
-- bridoc transformation: float stuff in
|
|
mGet >>= transformSimplifyFloating .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf
|
|
"bridoc post-floating"
|
|
_dconf_dump_bridoc_simpl_floating
|
|
-- bridoc transformation: par removal
|
|
mGet >>= transformSimplifyPar .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
|
|
-- bridoc transformation: float stuff in
|
|
mGet >>= transformSimplifyColumns .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
|
|
-- bridoc transformation: indent
|
|
mGet >>= transformSimplifyIndent .> mSet
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
|
|
mGet
|
|
>>= briDocToDoc
|
|
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
|
|
-- -- convert to Simple type
|
|
-- simpl <- mGet <&> transformToSimple
|
|
-- return simpl
|
|
|
|
anns :: ExactPrint.Anns <- mAsk
|
|
|
|
let
|
|
state = LayoutState
|
|
{ _lstate_baseYs = [0]
|
|
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
|
|
-- here because moveToAnn stuff
|
|
-- of the first node needs to do
|
|
-- its thing properly.
|
|
, _lstate_indLevels = [0]
|
|
, _lstate_indLevelLinger = 0
|
|
, _lstate_comments = anns
|
|
, _lstate_commentCol = Nothing
|
|
, _lstate_addSepSpace = Nothing
|
|
, _lstate_commentNewlines = 0
|
|
}
|
|
|
|
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
|
|
|
let
|
|
remainingComments =
|
|
[ c
|
|
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
|
|
(_lstate_comments state')
|
|
-- With the new import layouter, we manually process comments
|
|
-- without relying on the backend to consume the comments out of
|
|
-- the state/map. So they will end up here, and we need to ignore
|
|
-- them.
|
|
, ExactPrint.unConName con /= "ImportDecl"
|
|
, c <- extractAllComments elemAnns
|
|
]
|
|
remainingComments
|
|
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)
|
|
|
|
return $ ()
|