hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Refactor+Rewrite+Adaptation for ghc-9.2 support

ghc92
Lennart Spitzner 2022-12-17 14:48:55 +01:00
parent dedeab61e2
commit d11141d34d
50 changed files with 6739 additions and 6164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
brittany.cabal
View File

@ -38,9 +38,9 @@ flag pedantic
common library
build-depends:
, aeson ^>= 2.0.1
, base ^>= 4.15.0
, base >= 4.15.0 && < 4.17
, butcher ^>= 2.0.0
, bytestring ^>= 0.10.12
, bytestring >= 0.10.12 && < 0.12
, cmdargs ^>= 0.10.21
, containers ^>= 0.6.4
, czipwith ^>= 1.0.1
@ -49,17 +49,17 @@ common library
, directory ^>= 1.3.6
, extra ^>= 1.7.10
, filepath ^>= 1.4.2
, ghc ^>= 9.0.1
, ghc-boot ^>= 9.0.1
, ghc-boot-th ^>= 9.0.1
, ghc-exactprint ^>= 0.6.4
, ghc >= 9.0.1 && < 9.3
, ghc-boot >= 9.0.1 && < 9.3
, ghc-boot-th >= 9.0.1 && < 9.3
, ghc-exactprint >= 0.6.4 && < 1.6
, monad-memo ^>= 0.5.3
, mtl ^>= 2.2.2
, multistate ^>= 0.8.0
, pretty ^>= 1.1.3
, random ^>= 1.2.1
, safe ^>= 0.3.19
, semigroups ^>= 0.19.2
, semigroups >= 0.19.2 && < 0.21
, strict ^>= 0.4.0
, syb ^>= 0.7.2
, text ^>= 1.2.5
@ -86,6 +86,21 @@ common library
if flag(pedantic)
ghc-options: -Werror
default-extensions: {
FlexibleContexts
FlexibleInstances
ScopedTypeVariables
MonadComprehensions
LambdaCase
MultiWayIf
KindSignatures
MultiParamTypeClasses
TypeApplications
RankNTypes
GADTs
BangPatterns
}
common executable
import: library
@ -103,36 +118,42 @@ library
autogen-modules: Paths_brittany
hs-source-dirs: source/library
exposed-modules:
Language.Haskell.Brittany.Main
Language.Haskell.Brittany
Language.Haskell.Brittany.Internal
Language.Haskell.Brittany.Internal.Backend
Language.Haskell.Brittany.Internal.BackendUtils
Language.Haskell.Brittany.Internal.Config
Language.Haskell.Brittany.Internal.Config.Config
Language.Haskell.Brittany.Internal.Config.InlineParsing
Language.Haskell.Brittany.Internal.Config.Types
Language.Haskell.Brittany.Internal.Config.Types.Instances
Language.Haskell.Brittany.Internal.ExactPrintUtils
Language.Haskell.Brittany.Internal.LayouterBasics
Language.Haskell.Brittany.Internal.Layouters.DataDecl
Language.Haskell.Brittany.Internal.Layouters.Decl
Language.Haskell.Brittany.Internal.Layouters.Expr
Language.Haskell.Brittany.Internal.Layouters.IE
Language.Haskell.Brittany.Internal.Layouters.Import
Language.Haskell.Brittany.Internal.Layouters.Module
Language.Haskell.Brittany.Internal.Layouters.Pattern
Language.Haskell.Brittany.Internal.Layouters.Stmt
Language.Haskell.Brittany.Internal.Layouters.Type
Language.Haskell.Brittany.Internal.Obfuscation
Language.Haskell.Brittany.Internal.ParseModule
Language.Haskell.Brittany.Internal.Config.Types.Instances1
Language.Haskell.Brittany.Internal.Config.Types.Instances2
Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl
Language.Haskell.Brittany.Internal.ToBriDoc.Decl
Language.Haskell.Brittany.Internal.ToBriDoc.Expr
Language.Haskell.Brittany.Internal.ToBriDoc.IE
Language.Haskell.Brittany.Internal.ToBriDoc.Import
Language.Haskell.Brittany.Internal.ToBriDoc.Module
Language.Haskell.Brittany.Internal.ToBriDoc.Pattern
Language.Haskell.Brittany.Internal.ToBriDoc.Stmt
Language.Haskell.Brittany.Internal.ToBriDoc.Type
Language.Haskell.Brittany.Internal.Components.BriDoc
Language.Haskell.Brittany.Internal.Components.Obfuscation
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.Prelude
Language.Haskell.Brittany.Internal.PreludeUtils
Language.Haskell.Brittany.Internal.Transformations.Alt
Language.Haskell.Brittany.Internal.Transformations.Columns
Language.Haskell.Brittany.Internal.Transformations.Floating
Language.Haskell.Brittany.Internal.Transformations.Indent
Language.Haskell.Brittany.Internal.Transformations.Par
Language.Haskell.Brittany.Internal.Transformations.T1_Alt
Language.Haskell.Brittany.Internal.Transformations.T2_Floating
Language.Haskell.Brittany.Internal.Transformations.T3_Par
Language.Haskell.Brittany.Internal.Transformations.T4_Columns
Language.Haskell.Brittany.Internal.Transformations.T5_Indent
Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
Language.Haskell.Brittany.Internal.WriteBriDoc.Types
Language.Haskell.Brittany.Internal.Types
Language.Haskell.Brittany.Internal.Utils
Language.Haskell.Brittany.Main
Language.Haskell.Brittany.Internal.Util.AST
Paths_brittany
executable brittany
@ -145,7 +166,7 @@ test-suite brittany-test-suite
import: executable
build-depends:
, hspec ^>= 2.8.3
, hspec >= 2.8.3 && < 2.10
, parsec ^>= 3.1.14
, these ^>= 1.1
hs-source-dirs: source/test-suite

20
data/15-regressions.blt
View File

@ -116,7 +116,7 @@ func = do
let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'
(bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''
-- default local dir target if there's no given target
utargets'' = "foo"
utargets'' = "foo"
return ()
#test list comprehension comment placement
@ -872,3 +872,21 @@ func =
do
y
>>= x
#test nested-arrow-type
#pending
fieldWith
:: a
-> a
-> ( ( GHC.RealSrcLoc
, a
, Either
(Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered)
( Maybe GHC.RealSrcLoc
, ToBriDocM BriDocNumbered
, ToBriDocM BriDocNumbered
)
)
-> ToBriDocM BriDocNumbered
)
-> [ToBriDocM BriDocNumbered]

9
source/library/Language/Haskell/Brittany.hs
View File

@ -1,9 +1,9 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany
( parsePrintModule
, staticDefaultConfig
, forwardOptionsSyntaxExtsEnabled
-- ( parsePrintModule
-- , staticDefaultConfig
( forwardOptionsSyntaxExtsEnabled
, userConfigPath
, findLocalConfigPath
, readConfigs
@ -18,7 +18,6 @@ module Language.Haskell.Brittany
, BrittanyError(..)
) where
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types

689
source/library/Language/Haskell/Brittany/Internal.hs
View File

@ -1,232 +1,42 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Brittany.Internal
( parsePrintModule
( Parsing.parseModule
, Parsing.parseModuleFromString
, parsePrintModule
, parsePrintModuleTests
, pPrintModule
, processModule
, pPrintModuleAndCheck
-- re-export from utils:
, parseModule
, parseModuleFromString
, extractCommentConfigs
, getTopLevelDeclNameMap
) where
, TraceFunc(TraceFunc)
)
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
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 ()
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")
$ either
(\_ -> Butcher.Failure Nothing)
(\lconf -> Butcher.Success (mempty { _conf_layout = lconf }) "")
. 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.runCmdParserSimpleString 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.
@ -238,143 +48,104 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
-- `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 }
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
(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
let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack @CPPMode
let hackAroundIncludes =
config_pp & _ppconf_hackAroundIncludes & confUnpack @Bool
(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
Left err -> throwE [ErrorInput err]
Right x -> pure x
(inlineConf, perItemConf) <-
either (throwE . (: []) . uncurry ErrorMacroConfig) pure
$ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
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
let disableFormatting =
moduleConfig & _conf_disable_formatting & confUnpack @Bool
if disableFormatting
then do
return inputText
else do
(errsWarns, outputTextL) <- do
let
omitCheck =
moduleConfig
& _conf_errorHandling
& _econf_omit_output_valid_check
& confUnpack
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
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
$ 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)
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
-- 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
:: TraceFunc
-> 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{} -> []
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)
@ -383,42 +154,48 @@ pPrintModuleAndCheck conf inlineConf anns parsedModule = do
parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text)
parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input
parseResult <- parseModuleFromString
parseResult <- Parsing.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
Left err -> return $ Left err
Right (parsedModule, _) -> runExceptT $ do
(inlineConf, perItemConf) <-
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x
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
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
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
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
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.
@ -453,142 +230,7 @@ parsePrintModuleTests conf filename input = do
-- 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
@ -600,86 +242,7 @@ _bindHead :: HsBind GhcPs -> String
_bindHead = \case
FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind"
_ -> "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 $ ()

275
source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs Normal file
View File

@ -0,0 +1,275 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
module Language.Haskell.Brittany.Internal.Components.BriDoc where
import Language.Haskell.Brittany.Internal.Prelude
import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Data
import GHC (RealSrcLoc, LEpaComment)
-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot
-- of transformations on `BriDocF Identity`s and it is really annoying to
-- `Identity`/`runIdentity` everywhere.
data BriDoc
= -- BDWrapAnnKey AnnKey BriDoc
BDEmpty
| BDLit !Text
| BDSeq [BriDoc] -- elements other than the last should
-- not contains BDPars.
| BDCols ColSig [BriDoc] -- elements other than the last
-- should not contains BDPars
| BDSeparator -- semantically, space-unless-at-end-of-line.
| BDAddBaseY BrIndent BriDoc
| BDBaseYPushCur BriDoc
| BDBaseYPop BriDoc
| BDIndentLevelPushCur BriDoc
| BDIndentLevelPop BriDoc
| BDPar
{ _bdpar_indent :: BrIndent
, _bdpar_restOfLine :: BriDoc -- should not contain other BDPars
, _bdpar_indented :: BriDoc
}
-- | BDAddIndent BrIndent (BriDocF f)
-- | BDNewline
| BDAlt [BriDoc]
| BDForwardLineMode BriDoc
| BDExternal -- AnnKey
-- (Set AnnKey) -- set of annkeys contained within the node
-- -- to be printed via exactprint
Bool -- should print extra comment ?
Text
| BDPlain !Text -- used for QuasiQuotes, content can be multi-line
-- (contrast to BDLit)
| BDQueueComments [LEpaComment] BriDoc
-- queue to be later flushed when the markers are reached
| BDFlushCommentsPrior RealSrcLoc BriDoc
-- process comments before loc from the queue
| BDFlushCommentsPost RealSrcLoc BriDoc
-- process comments before loc from the queue, but flow to end of
-- child-nodes
| BDLines [BriDoc]
| BDEnsureIndent BrIndent BriDoc
-- the following constructors are only relevant for the alt transformation
-- and are removed afterwards. They should never occur in any BriDoc
-- after the alt transformation.
| BDForceMultiline BriDoc
| BDForceSingleline BriDoc
| BDNonBottomSpacing Bool BriDoc
| BDSetParSpacing BriDoc
| BDForceParSpacing BriDoc
-- pseudo-deprecated
| BDDebug String BriDoc
deriving (Data.Data.Data, Eq, Ord)
data BriDocF f
= -- BDWrapAnnKey AnnKey BriDoc
BDFEmpty
| BDFLit !Text
| BDFSeq [f (BriDocF f)] -- elements other than the last should
-- not contains BDPars.
| BDFCols ColSig [f (BriDocF f)] -- elements other than the last
-- should not contains BDPars
| BDFSeparator -- semantically, space-unless-at-end-of-line.
| BDFAddBaseY BrIndent (f (BriDocF f))
| BDFBaseYPushCur (f (BriDocF f))
| BDFBaseYPop (f (BriDocF f))
| BDFIndentLevelPushCur (f (BriDocF f))
| BDFIndentLevelPop (f (BriDocF f))
| BDFPar
{ _bdfpar_indent :: BrIndent
, _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars
, _bdfpar_indented :: f (BriDocF f)
}
-- | BDAddIndent BrIndent (BriDocF f)
-- | BDNewline
| BDFAlt [f (BriDocF f)]
| BDFForwardLineMode (f (BriDocF f))
| BDFExternal -- AnnKey
-- (Set AnnKey) -- set of annkeys contained within the node
-- -- to be printed via exactprint
Bool -- should print extra comment ?
Text
| BDFPlain !Text -- used for QuasiQuotes, content can be multi-line
-- (contrast to BDLit)
| BDFQueueComments [LEpaComment] (f (BriDocF f))
-- ^ true = comments will be left in the queue when the node is left
| BDFFlushCommentsPrior RealSrcLoc (f (BriDocF f))
-- process comments before loc from the queue
| BDFFlushCommentsPost RealSrcLoc (f (BriDocF f))
-- process comments before loc from the queue, but flow to end of
-- child-nodes
| BDFLines [(f (BriDocF f))]
| BDFEnsureIndent BrIndent (f (BriDocF f))
| BDFForceMultiline (f (BriDocF f))
| BDFForceSingleline (f (BriDocF f))
| BDFNonBottomSpacing Bool (f (BriDocF f))
| BDFSetParSpacing (f (BriDocF f))
| BDFForceParSpacing (f (BriDocF f))
| BDFDebug String (f (BriDocF f))
data BrIndent = BrIndentNone
| BrIndentRegular
| BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show)
-- deriving instance Data.Data.Data (BriDocF Identity)
deriving instance Data.Data.Data (BriDocF ((,) Int))
type BriDocFInt = BriDocF ((,) Int)
type BriDocNumbered = (Int, BriDocFInt)
instance Uniplate.Uniplate BriDoc where
uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x
uniplate (BDSeq list ) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts ) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x
uniplate (BDQueueComments comms bd) =
plate BDQueueComments |- comms |* bd
uniplate (BDFlushCommentsPrior loc bd) =
plate BDFlushCommentsPrior |- loc |* bd
uniplate (BDFlushCommentsPost loc bd) =
plate BDFlushCommentsPost |- loc |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd
-- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case
BDEmpty -> ()
BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> ()
BDPlain{} -> ()
BDQueueComments _comms bd -> briDocSeqSpine bd
BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd
BDFlushCommentsPost _loc bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing _ bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd
briDocForceSpine :: BriDoc -> BriDoc
briDocForceSpine bd = briDocSeqSpine bd `seq` bd
isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False
isNotEmpty _ = True
-- TODO: rename to "dropLabels" ?
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
unwrapBriDocNumbered tpl = case snd tpl of
BDFEmpty -> BDEmpty
BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal c t -> BDExternal c t
BDFPlain t -> BDPlain t
BDFQueueComments comms bd -> BDQueueComments comms $ rec bd
BDFFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd
BDFFlushCommentsPost loc bd -> BDFlushCommentsPost loc $ rec bd
BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where rec = unwrapBriDocNumbered
data ColSig
= ColTyOpPrefix
-- any prefixed operator/paren/"::"/..
-- expected to have exactly two colums.
-- e.g. ":: foo"
-- 111222
-- "-> bar asd asd"
-- 11122222222222
| ColPatternsFuncPrefix
-- pattern-part of the lhs, e.g. "func (foo a b) c _".
-- Has variable number of columns depending on the number of patterns.
| ColPatternsFuncInfix
-- pattern-part of the lhs, e.g. "Foo a <> Foo b".
-- Has variable number of columns depending on the number of patterns.
| ColPatterns
| ColCasePattern
| ColBindingLine (Maybe Text)
-- e.g. "func pat pat = expr"
-- 1111111111111222222
-- or "pat | stmt -> expr"
-- 111111111112222222
-- expected to have exactly two columns.
| ColGuard
-- e.g. "func pat pat | cond = ..."
-- 11111111111112222222
-- or "pat | cond1, cond2 -> ..."
-- 1111222222222222222
-- expected to have exactly two columns
| ColGuardedBody
-- e.g. | foofoo = 1
-- | bar = 2
-- 111111111222
-- expected to have exactly two columns
| ColBindStmt
| ColDoLet -- the non-indented variant
| ColRec
| ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
| ColRecDecl
| ColListComp
| ColList
| ColApp Text
| ColTuple
| ColTuples
| ColOpPrefix -- merge with ColList ? other stuff?
| ColImport
-- TODO
deriving (Eq, Ord, Data.Data.Data, Show)

3
source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs → source/library/Language/Haskell/Brittany/Internal/Components/Obfuscation.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Obfuscation where
module Language.Haskell.Brittany.Internal.Components.Obfuscation where
import Data.Char
import qualified Data.Map as Map
@ -8,7 +8,6 @@ import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import System.Random

35
source/library/Language/Haskell/Brittany/Internal/Config.hs → source/library/Language/Haskell/Brittany/Internal/Config/Config.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Config where
module Language.Haskell.Brittany.Internal.Config.Config where
import qualified Data.Bool as Bool
import qualified Data.ByteString as ByteString
@ -13,9 +13,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Yaml
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
-- import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Utils
import qualified System.Console.CmdArgs.Explicit as CmdArgs
import qualified System.Directory
@ -208,7 +207,9 @@ cmdlineConfigParser = do
-- If the second parameter is True and the file does not exist, writes the
-- staticDefaultConfig to the file.
readConfig
:: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe))
:: (MonadIO m, Data.Yaml.FromJSON (CConfig Maybe))
=> System.IO.FilePath
-> MaybeT m (Maybe (CConfig Maybe))
readConfig path = do
-- TODO: probably should catch IOErrors and then omit the existence check.
exists <- liftIO $ System.Directory.doesFileExist path
@ -230,7 +231,9 @@ readConfig path = do
-- | Looks for a user-global config file and return its path.
-- If there is no global config in a system, one will be created.
userConfigPath :: IO System.IO.FilePath
userConfigPath
:: (Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig)
=> IO System.IO.FilePath
userConfigPath = do
userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"
userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
@ -257,7 +260,11 @@ findLocalConfigPath dir = do
-- | Reads specified configs.
readConfigs
:: CConfig Maybe -- ^ Explicit options, take highest priority
:: ( Data.Yaml.FromJSON (CConfig Maybe)
, Monoid (CConfig Maybe)
, CZipWith CConfig
)
=> CConfig Maybe -- ^ Explicit options, take highest priority
-> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first
-> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do
@ -270,19 +277,29 @@ readConfigs cmdlineConfig configPaths = do
-- | Reads provided configs
-- but also applies the user default configuration (with lowest priority)
readConfigsWithUserConfig
:: CConfig Maybe -- ^ Explicit options, take highest priority
:: ( Data.Yaml.ToJSON (CConfig Maybe)
, Data.Yaml.FromJSON (CConfig Maybe)
, Monoid (CConfig Maybe)
, CFunctor CConfig
, CZipWith CConfig
)
=> CConfig Maybe -- ^ Explicit options, take highest priority
-> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first
-> MaybeT IO Config
readConfigsWithUserConfig cmdlineConfig configPaths = do
defaultPath <- liftIO $ userConfigPath
readConfigs cmdlineConfig (configPaths ++ [defaultPath])
writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m ()
writeDefaultConfig
:: (MonadIO m, Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig)
=> System.IO.FilePath
-> m ()
writeDefaultConfig path =
liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap
(Just . runIdentity)
staticDefaultConfig
showConfigYaml :: Config -> String
showConfigYaml
:: (Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig) => Config -> String
showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap
(\(Identity x) -> Just x)

194
source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs Normal file
View File

@ -0,0 +1,194 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Config.InlineParsing
( extractCommentConfigs
)
where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.ByteString.Char8
import Data.Char ( isSpace )
import qualified Data.Map as Map
import qualified Data.Yaml
import qualified GHC
import GHC ( EpaComment(EpaComment)
, GenLocated(L)
)
import qualified GHC.OldList as List
import GHC.Parser.Annotation ( EpaCommentTok
( EpaBlockComment
, EpaLineComment
)
)
import qualified UI.Butcher.Monadic as Butcher
-- import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Control.Monad.Trans.Except
import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Util.AST
import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ()
-- import Language.Haskell.Brittany.Internal.Utils
data InlineConfigTarget
= InlineConfigTargetModule
| InlineConfigTargetNextDecl -- really only next in module
| InlineConfigTargetNextBinding -- by name
| InlineConfigTargetBinding String
extractCommentConfigs
:: (String -> IO ())
-> GHC.ParsedSource
-> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig)
extractCommentConfigs _putErrorLn modul = do
let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul
let declMap :: Map GHC.RealSrcSpan [String]
declMap = Map.fromList
[ ( case span of
GHC.RealSrcSpan s _ -> s
GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
, getDeclBindingNames decl
)
| decl <- decls
, let (L (GHC.SrcSpanAnn _ span) _) = decl
]
let epAnnComms = \case
GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
prior ++ following
GHC.EpAnnNotUsed -> []
let gatheredComments =
join
$ epAnnComms modAnn
: [ epAnnComms epAnn | L (GHC.SrcSpanAnn epAnn _) _x <- decls ]
-- gatheredComments `forM_` \comm@(L anchor _) -> do
-- liftIO $ putErrorLn $ showOutputable comm
-- case Map.lookupLE (GHC.anchor anchor) declMap of
-- Nothing -> pure ()
-- Just (pos, le) -> do
-- liftIO $ putErrorLn $ " le = " ++ show (toConstr le) ++ " at " ++ show
-- (ExactPrint.Utils.ss2deltaEnd pos (GHC.anchor anchor))
-- case Map.lookupGE (GHC.anchor anchor) declMap of
-- Nothing -> pure ()
-- Just (pos, ge) -> do
-- liftIO $ putErrorLn $ " ge = " ++ show (toConstr ge) ++ " at " ++ show
-- (ExactPrint.Utils.ss2deltaStart (GHC.anchor anchor) pos)
lineConfigs <- sequence
[ case Butcher.runCmdParserSimpleString line2 parser of
Left err -> throwE (err, line2)
Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf)
| L anchr (EpaComment comm _) <- gatheredComments
, Just line1 <- case comm of
EpaLineComment l ->
[ List.stripPrefix "-- BRITTANY" l
<|> List.stripPrefix "--BRITTANY" l
<|> List.stripPrefix "-- brittany" l
<|> List.stripPrefix "--brittany" l
]
EpaBlockComment l ->
[List.stripPrefix "{- BRITTANY" l >>= stripSuffix "-}"]
_ -> []
, let line2 = dropWhile isSpace line1
, ( ("@" `isPrefixOf` line2)
|| ("-disable" `isPrefixOf` line2)
|| ("-next" `isPrefixOf` line2)
|| ("{" `isPrefixOf` line2)
|| ("--" `isPrefixOf` line2)
)
]
let perModule = foldl'
(<>)
mempty
[ conf | (_, InlineConfigTargetModule, conf) <- lineConfigs ]
let perBinding = Map.fromListWith
(<>)
[ (n, conf)
| (srcSpan, target, conf) <- lineConfigs
, let perBindRes = Map.lookupGT srcSpan declMap
, n <- case target of
InlineConfigTargetBinding s -> [s]
InlineConfigTargetNextBinding | Just (_, names) <- perBindRes -> names
_ -> []
]
let perSpan = Map.fromListWith
(<>)
[ (srcSpan, conf)
| (srcSpan, target, conf) <- lineConfigs
, let perBindRes = Map.lookupGT srcSpan declMap
, case target of
InlineConfigTargetNextDecl -> True
InlineConfigTargetNextBinding | Nothing <- perBindRes -> True
_ -> False
]
pure
$ ( perModule
, PerItemConfig { _icd_perBinding = perBinding, _icd_perAnchor = perSpan }
)
where
configParser = Butcher.addAlternatives
[ ( "commandline-config"
, \s -> "-" `isPrefixOf` dropWhile (== ' ') s
, cmdlineConfigParser
)
, ( "yaml-config-document"
, \s -> "{" `isPrefixOf` dropWhile (== ' ') s
, Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")
$ either
(\_ -> Butcher.Failure Nothing)
(\lconf -> Butcher.Success (mempty { _conf_layout = lconf }) "")
. 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)

93
source/library/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

@ -7,19 +7,16 @@
module Language.Haskell.Brittany.Internal.Config.Types where
import Data.CZipWith
import Data.Coerce (Coercible, coerce)
import Data.Data (Data)
import qualified Data.Semigroup as Semigroup
import Data.Semigroup (Last)
import Data.Semigroup.Generic
import GHC.Generics
import GHC (RealSrcSpan)
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils ()
confUnpack :: Coercible a b => Identity a -> b
confUnpack :: forall b a . Coercible a b => Identity a -> b
confUnpack (Identity x) = coerce x
data CDebugConfig f = DebugConfig
@ -196,74 +193,10 @@ type ForwardOptions = CForwardOptions Identity
type ErrorHandlingConfig = CErrorHandlingConfig Identity
type Config = CConfig Identity
-- i wonder if any Show1 stuff could be leveraged.
deriving instance Show (CDebugConfig Identity)
deriving instance Show (CLayoutConfig Identity)
deriving instance Show (CErrorHandlingConfig Identity)
deriving instance Show (CForwardOptions Identity)
deriving instance Show (CPreProcessorConfig Identity)
deriving instance Show (CConfig Identity)
deriving instance Show (CDebugConfig Maybe)
deriving instance Show (CLayoutConfig Maybe)
deriving instance Show (CErrorHandlingConfig Maybe)
deriving instance Show (CForwardOptions Maybe)
deriving instance Show (CPreProcessorConfig Maybe)
deriving instance Show (CConfig Maybe)
deriving instance Data (CDebugConfig Identity)
deriving instance Data (CLayoutConfig Identity)
deriving instance Data (CErrorHandlingConfig Identity)
deriving instance Data (CForwardOptions Identity)
deriving instance Data (CPreProcessorConfig Identity)
deriving instance Data (CConfig Identity)
deriving instance Data (CDebugConfig Maybe)
deriving instance Data (CLayoutConfig Maybe)
deriving instance Data (CErrorHandlingConfig Maybe)
deriving instance Data (CForwardOptions Maybe)
deriving instance Data (CPreProcessorConfig Maybe)
deriving instance Data (CConfig Maybe)
instance Semigroup.Semigroup (CDebugConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CLayoutConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CForwardOptions Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CDebugConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CLayoutConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CForwardOptions Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CPreProcessorConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CConfig Identity) where
(<>) = gmappend
instance Monoid (CDebugConfig Maybe) where
mempty = gmempty
instance Monoid (CLayoutConfig Maybe) where
mempty = gmempty
instance Monoid (CErrorHandlingConfig Maybe) where
mempty = gmempty
instance Monoid (CForwardOptions Maybe) where
mempty = gmempty
instance Monoid (CPreProcessorConfig Maybe) where
mempty = gmempty
instance Monoid (CConfig Maybe) where
mempty = gmempty
data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe)
, _icd_perAnchor :: Map RealSrcSpan (CConfig Maybe)
}
data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more
-- than old indentation + amount
@ -322,17 +255,3 @@ data ExactPrintFallbackMode
-- THIS MAY THEORETICALLY CHANGE SEMANTICS OF
-- A PROGRAM BY TRANSFORMING IT.
deriving (Show, Generic, Data)
deriveCZipWith ''CDebugConfig
deriveCZipWith ''CLayoutConfig
deriveCZipWith ''CErrorHandlingConfig
deriveCZipWith ''CForwardOptions
deriveCZipWith ''CPreProcessorConfig
deriveCZipWith ''CConfig
instance CFunctor CDebugConfig
instance CFunctor CLayoutConfig
instance CFunctor CErrorHandlingConfig
instance CFunctor CForwardOptions
instance CFunctor CPreProcessorConfig
instance CFunctor CConfig

6
source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs → source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs
View File

@ -13,10 +13,12 @@
{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -fignore-interface-pragmas #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.Brittany.Internal.Config.Types.Instances where
module Language.Haskell.Brittany.Internal.Config.Types.Instances1 where
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.Types as Aeson

102
source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances2.hs Normal file
View File

@ -0,0 +1,102 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Language.Haskell.Brittany.Internal.Config.Types.Instances2 where
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.Semigroup as Semigroup
import Data.Semigroup.Generic
import Data.CZipWith
import Data.Data(Data)
-- i wonder if any Show1 stuff could be leveraged.
deriving instance Show (CDebugConfig Identity)
deriving instance Show (CLayoutConfig Identity)
deriving instance Show (CErrorHandlingConfig Identity)
deriving instance Show (CForwardOptions Identity)
deriving instance Show (CPreProcessorConfig Identity)
deriving instance Show (CConfig Identity)
deriving instance Show (CDebugConfig Maybe)
deriving instance Show (CLayoutConfig Maybe)
deriving instance Show (CErrorHandlingConfig Maybe)
deriving instance Show (CForwardOptions Maybe)
deriving instance Show (CPreProcessorConfig Maybe)
deriving instance Show (CConfig Maybe)
instance Semigroup.Semigroup (CDebugConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CLayoutConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CForwardOptions Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CConfig Maybe) where
(<>) = gmappend
instance Semigroup.Semigroup (CDebugConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CLayoutConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CForwardOptions Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CPreProcessorConfig Identity) where
(<>) = gmappend
instance Semigroup.Semigroup (CConfig Identity) where
(<>) = gmappend
instance Monoid (CDebugConfig Maybe) where
mempty = gmempty
instance Monoid (CLayoutConfig Maybe) where
mempty = gmempty
instance Monoid (CErrorHandlingConfig Maybe) where
mempty = gmempty
instance Monoid (CForwardOptions Maybe) where
mempty = gmempty
instance Monoid (CPreProcessorConfig Maybe) where
mempty = gmempty
instance Monoid (CConfig Maybe) where
mempty = gmempty
deriveCZipWith ''CDebugConfig
deriveCZipWith ''CLayoutConfig
deriveCZipWith ''CErrorHandlingConfig
deriveCZipWith ''CForwardOptions
deriveCZipWith ''CPreProcessorConfig
deriveCZipWith ''CConfig
instance CFunctor CDebugConfig
instance CFunctor CLayoutConfig
instance CFunctor CErrorHandlingConfig
instance CFunctor CForwardOptions
instance CFunctor CPreProcessorConfig
instance CFunctor CConfig
deriving instance Data PerItemConfig
deriving instance Data (CDebugConfig Identity)
deriving instance Data (CLayoutConfig Identity)
deriving instance Data (CErrorHandlingConfig Identity)
deriving instance Data (CForwardOptions Identity)
deriving instance Data (CPreProcessorConfig Identity)
deriving instance Data (CConfig Identity)
deriving instance Data (CDebugConfig Maybe)
deriving instance Data (CLayoutConfig Maybe)
deriving instance Data (CErrorHandlingConfig Maybe)
deriving instance Data (CForwardOptions Maybe)
deriving instance Data (CPreProcessorConfig Maybe)
deriving instance Data (CConfig Maybe)

254
source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -1,254 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Brittany.Internal.ExactPrintUtils where
import qualified Control.Monad.State.Class as State.Class
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.Data
import qualified Data.Foldable as Foldable
import qualified Data.Generics as SYB
import Data.HList.HList
import qualified Data.Map as Map
import qualified Data.Maybe
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import GHC (GenLocated(L))
import qualified GHC hiding (parseModule)
import qualified GHC.Driver.CmdLine as GHC
import GHC.Hs
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.SrcLoc (Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO
parseModule
:: [String]
-> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a))
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModule args fp dynCheck = do
str <- System.IO.readFile fp
parseModuleFromString args fp dynCheck str
parseModuleFromString
:: [String]
-> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a))
-> String
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleFromString = ParseModule.parseModule
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do
let
extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
const Seq.empty
`SYB.ext1Q` (\l@(L span _) ->
Seq.singleton (span, ExactPrint.mkAnnKey l)
)
let nodes = SYB.everything (<>) extract ast
let
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith
(const id)
[ (GHC.realSrcSpanEnd span, annKey)
| (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
]
nodes `forM_` (snd .> processComs annsMap)
where
processComs annsMap annKey1 = do
mAnn <- State.Class.gets fst <&> Map.lookup annKey1
mAnn `forM_` \ann1 -> do
let
priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let
processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
-> ExactPrint.TransformT Identity Bool
processCom comPair@(com, _) =
case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
comLoc -> case Map.lookupLE comLoc annsMap of
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False
(x, y) | x == y -> move $> False
_ -> return True
where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.realSrcSpanStart annKeyLoc1
loc2 = GHC.realSrcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns ->
let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2
{ ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair]
}
in Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node.
priors' <- filterM processCom priors
follows' <- filterM processCom follows
assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True
let
ann1' = ann1
{ ExactPrint.annPriorComments = priors'
, ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs'
}
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
-- TODO: this is unused by now, but it contains one detail that
-- commentAnnFixTransformGlob does not include: Moving of comments for
-- "RecordUpd"s.
-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
-- commentAnnFixTransform modul = SYB.everything (>>) genF modul
-- where
-- genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
-- genF = (\_ -> return ()) `SYB.extQ` exprF
-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
-- exprF lexpr@(L _ expr) = case expr of
-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
-- #else
-- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->
-- #endif
-- moveTrailingComments lexpr (List.last fs)
-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
-- RecordUpd _ _e fs@(_:_) ->
-- #else
-- RecordUpd _e fs@(_:_) _cons _ _ _ ->
-- #endif
-- moveTrailingComments lexpr (List.last fs)
-- _ -> return ()
-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
-- commentAnnFixTransform modul = SYB.everything (>>) genF modul
-- where
-- genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
-- genF = (\_ -> return ()) `SYB.extQ` exprF
-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
-- exprF lexpr@(L _ expr) = case expr of
-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
-- moveTrailingComments lexpr (List.last fs)
-- RecordUpd _ _e fs@(_:_) ->
-- moveTrailingComments lexpr (List.last fs)
-- _ -> return ()
-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
-- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
-- moveTrailingComments astFrom astTo = do
-- let
-- k1 = ExactPrint.mkAnnKey astFrom
-- k2 = ExactPrint.mkAnnKey astTo
-- moveComments ans = ans'
-- where
-- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
-- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
-- cs1f = ExactPrint.annFollowingComments an1
-- cs2f = ExactPrint.annFollowingComments an2
-- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)
-- $ \case
-- (ExactPrint.AnnComment com, dp) -> Left (com, dp)
-- x -> Right x
-- an1' = an1
-- { ExactPrint.annsDP = nonComments
-- , ExactPrint.annFollowingComments = []
-- }
-- an2' = an2
-- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
-- }
-- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
-- ExactPrint.modifyAnnsT moveComments
-- | split a set of annotations in a module into a map from top-level module
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have.
extractToplevelAnns
:: Located HsModule
-> ExactPrint.Anns
-> Map ExactPrint.AnnKey ExactPrint.Anns
extractToplevelAnns lmod anns = output
where
(L _ (HsModule _ _ _ _ ldecls _ _)) = lmod
declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
declMap1 = Map.unions $ ldecls <&> \ldecl ->
Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)
declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
declMap2 =
Map.fromList
$ [ (captured, declMap1 Map.! k)
| (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
]
declMap = declMap1 `Map.union` declMap2
modKey = ExactPrint.mkAnnKey lmod
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
groupMap f = Map.foldlWithKey'
(\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty
where
insert k a Nothing = Just (Map.singleton k a)
insert k a (Just m) = Just (Map.insert k a m)
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = SYB.everything
Set.union
(\x -> maybe
Set.empty
Set.singleton
[ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
]
-- for some reason, ghc-8.8 has forgotten how to infer the type of l,
-- even though it is passed to mkAnnKey above, which only accepts
-- SrcSpan.
)
ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
withTransformedAnns
:: Data ast
=> ast
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS
MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)
x <- m
MultiRWSS.mPutRawR readers
pure x
where
f anns =
let
((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced
warnExtractorCompat :: GHC.Warn -> String
warnExtractorCompat (GHC.Warn _ (L _ s)) = s

781
source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
View File

@ -1,781 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.LayouterBasics where
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Control.Monad.Writer.Strict as Writer
import qualified Data.Char as Char
import Data.Data
import qualified Data.Map as Map
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import DataTreePrint
import GHC (GenLocated(L), Located, moduleName, moduleNameString)
import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.Name (getOccString)
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Types.Name.Reader (RdrName(..))
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
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.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
processDefault
:: ( ExactPrint.Annotate.Annotate ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiReader ExactPrint.Types.Anns m
)
=> Located ast
-> m ()
processDefault x = do
anns <- mAsk
let str = ExactPrint.exactPrint x anns
-- this hack is here so our print-empty-module trick does not add
-- a newline at the start if there actually is no module header / imports
-- / anything.
-- TODO: instead the appropriate annotation could be removed when "cleaning"
-- the module (header). This would remove the need for this hack!
case str of
"\n" -> return ()
_ -> mTell $ Text.Builder.fromString str
-- | Use ExactPrint's output for this node; add a newly generated inline comment
-- at insertion position (meant to point out to the user that this node is
-- not handled by brittany yet). Useful when starting implementing new
-- syntactic constructs when children are not handled yet.
briDocByExact
:: (ExactPrint.Annotate.Annotate ast)
=> Located ast
-> ToBriDocM BriDocNumbered
briDocByExact ast = do
anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True
-- | Use ExactPrint's output for this node.
-- Consider that for multi-line input, the indentation of the code produced
-- by ExactPrint might be different, and even incompatible with the indentation
-- of its surroundings as layouted by brittany. But there are safe uses of
-- this, e.g. for any top-level declarations.
briDocByExactNoComment
:: (ExactPrint.Annotate.Annotate ast)
=> Located ast
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do
anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False
-- | Use ExactPrint's output for this node, presuming that this output does
-- not contain any newlines. If this property is not met, the semantics
-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
briDocByExactInlineOnly
:: (ExactPrint.Annotate.Annotate ast)
=> String
-> Located ast
-> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do
anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let
exactPrintNode t = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey ast)
(foldedAnnKeys ast)
False
t
let
errorAction = do
mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
case (fallbackMode, Text.lines exactPrinted) of
(ExactPrintFallbackModeNever, _) -> errorAction
(_, [t]) -> exactPrintNode
(Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
(ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
_ -> errorAction
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
lrdrNameToText :: GenLocated l RdrName -> Text
lrdrNameToText (L _ n) = rdrNameToText n
lrdrNameToTextAnnGen
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
=> (Text -> Text)
-> Located RdrName
-> m Text
lrdrNameToTextAnnGen f ast@(L _ n) = do
anns <- mAsk
let t = f $ rdrNameToText n
let
hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe
-- choice.
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
Nothing -> t
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t
lrdrNameToTextAnn
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
=> Located RdrName
-> m Text
lrdrNameToTextAnn = lrdrNameToTextAnnGen id
lrdrNameToTextAnnTypeEqualityIsSpecial
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
=> Located RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let
f x = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
lrdrNameToTextAnnGen f ast
-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
-- the annotations for a (parent) node for a tick to be added to the
-- literal.
-- Excessively long name to reflect on us having to work around such
-- excessively obscure special cases in the exactprint API.
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
:: ( Data ast
, MonadMultiReader Config m
, MonadMultiReader (Map AnnKey Annotation) m
)
=> Located ast
-> Located RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2
let
lit = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
return $ if hasQuote then Text.cons '\'' lit else lit
askIndent :: (MonadMultiReader Config m) => m Int
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
extractAllComments
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
extractAllComments ann =
ExactPrint.annPriorComments ann ++ extractRestComments ann
extractRestComments
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
extractRestComments ann =
ExactPrint.annFollowingComments ann
++ (ExactPrint.annsDP ann >>= \case
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
_ -> []
)
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND
-- b) after (in source code order) the node.
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) =
List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
<$> astConnectedComments ast
hasCommentsBetween
:: Data ast
=> GHC.Located ast
-> AnnKeywordId
-> AnnKeywordId
-> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast
let
go1 [] = False
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 (_ : rest) = go1 rest
go2 [] = False
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 (_ : rest) = go2 rest
case mAnn of
Nothing -> pure False
Just ann -> pure $ go1 $ ExactPrint.annsDP ann
-- | True if there are any comments that are connected to any node below (in AST
-- sense) the given node
hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast
-- | Regular comments are comments that are actually "source code comments",
-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
-- used by ghc-exactprint for capturing symbols (and their exact positioning).
--
-- Only the type instance layouter makes use of this filter currently, but
-- it might make sense to apply it more aggressively or make it the default -
-- I believe that most of the time we branch on the existence of comments, we
-- only care about "regular" comments. We simply did not need the distinction
-- because "irregular" comments are not that common outside of type/data decls.
isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
astConnectedComments
:: Data ast
=> GHC.Located ast
-> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]
astConnectedComments ast = do
anns <- filterAnns ast <$> mAsk
pure $ extractAllComments =<< Map.elems anns
hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsPrior ast = astAnn ast <&> \case
Nothing -> False
Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsRest ast = astAnn ast <&> \case
Nothing -> False
Just ann -> any isRegularComment (extractRestComments ann)
hasAnnKeywordComment
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
Nothing -> False
Just ann -> any hasK (extractAllComments ann)
where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
hasAnnKeyword
:: (Data a, MonadMultiReader (Map AnnKey Annotation) m)
=> Located a
-> AnnKeywordId
-> m Bool
hasAnnKeyword ast annKeyword = astAnn ast <&> \case
Nothing -> False
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
where
hasK (ExactPrint.Types.G x, _) = x == annKeyword
hasK _ = False
astAnn
:: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
=> GHC.Located ast
-> m (Maybe Annotation)
astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk
-- new BriDoc stuff
allocateNode
:: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
allocateNode bd = do
i <- allocNodeIndex
return (i, bd)
allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
allocNodeIndex = do
NodeAllocIndex i <- mGet
mSet $ NodeAllocIndex (i + 1)
return i
-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
-- docEmpty = allocateNode BDFEmpty
--
-- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered
-- docLit t = allocateNode $ BDFLit t
--
-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)
-- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered
-- docExt x anns shouldAddComment = allocateNode $ BDFExternal
-- (ExactPrint.Types.mkAnnKey x)
-- (foldedAnnKeys x)
-- shouldAddComment
-- (Text.pack $ ExactPrint.exactPrint x anns)
--
-- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
-- docAlt l = allocateNode . BDFAlt =<< sequence l
--
--
-- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
-- docSeq l = allocateNode . BDFSeq =<< sequence l
--
-- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
-- docLines l = allocateNode . BDFLines =<< sequence l
--
-- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered
-- docCols sig l = allocateNode . BDFCols sig =<< sequence l
--
-- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered
-- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
--
-- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
-- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm
--
-- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
-- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm
--
-- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
-- docSeparator = allocateNode BDFSeparator
--
-- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered
-- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
--
-- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered
-- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm
--
-- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
-- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm
--
-- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
-- appSep x = docSeq [x, docSeparator]
--
-- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
-- docCommaSep = appSep $ docLit $ Text.pack ","
--
-- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
-- docParenLSep = appSep $ docLit $ Text.pack "("
--
--
-- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
-- => Located ast
-- -> m BriDocNumbered
-- -> m BriDocNumbered
-- docPostComment ast bdm = do
-- bd <- bdm
-- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd
--
-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
-- => Located ast
-- -> m BriDocNumbered
-- -> m BriDocNumbered
-- docWrapNode ast bdm = do
-- bd <- bdm
-- i1 <- allocNodeIndex
-- i2 <- allocNodeIndex
-- return
-- $ (,) i1
-- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
-- $ (,) i2
-- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
-- $ bd
--
-- docPar :: MonadMultiState NodeAllocIndex m
-- => m BriDocNumbered
-- -> m BriDocNumbered
-- -> m BriDocNumbered
-- docPar lineM indentedM = do
-- line <- lineM
-- indented <- indentedM
-- allocateNode $ BDFPar BrIndentNone line indented
--
-- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
-- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
--
-- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
-- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
--
-- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered
-- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
docEmpty :: ToBriDocM BriDocNumbered
docEmpty = allocateNode BDFEmpty
docLit :: Text -> ToBriDocM BriDocNumbered
docLit t = allocateNode $ BDFLit t
docLitS :: String -> ToBriDocM BriDocNumbered
docLitS s = allocateNode $ BDFLit $ Text.pack s
docExt
:: (ExactPrint.Annotate.Annotate ast)
=> Located ast
-> ExactPrint.Types.Anns
-> Bool
-> ToBriDocM BriDocNumbered
docExt x anns shouldAddComment = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey x)
(foldedAnnKeys x)
shouldAddComment
(Text.pack $ ExactPrint.exactPrint x anns)
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docAlt l = allocateNode . BDFAlt =<< sequence l
newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc = when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action
docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docSeq [] = docEmpty
docSeq l = allocateNode . BDFSeq =<< sequence l
docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docLines l = allocateNode . BDFLines =<< sequence l
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docCols sig l = allocateNode . BDFCols sig =<< sequence l
docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetBaseY bdm = do
bd <- bdm
-- the order here is important so that these two nodes can be treated
-- properly over at `transformAlts`.
n1 <- allocateNode $ BDFBaseYPushCur bd
n2 <- allocateNode $ BDFBaseYPop n1
return n2
docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetIndentLevel bdm = do
bd <- bdm
n1 <- allocateNode $ BDFIndentLevelPushCur bd
n2 <- allocateNode $ BDFIndentLevelPop n1
return n2
docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetBaseAndIndent = docSetBaseY . docSetIndentLevel
docSeparator :: ToBriDocM BriDocNumbered
docSeparator = allocateNode BDFSeparator
docAnnotationPrior
:: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationPrior annKey bdm =
allocateNode . BDFAnnotationPrior annKey =<< bdm
docAnnotationKW
:: AnnKey
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm =
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP
:: AnnKey
-> AnnKeywordId
-> Bool
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docMoveToKWDP annKey kw shouldRestoreIndent bdm =
allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm
docAnnotationRest
:: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm
docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm
docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm
docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm
docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm
docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docDebug s bdm = allocateNode . BDFDebug s =<< bdm
appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
appSep x = docSeq [x, docSeparator]
docCommaSep :: ToBriDocM BriDocNumbered
docCommaSep = appSep $ docLit $ Text.pack ","
docParenLSep :: ToBriDocM BriDocNumbered
docParenLSep = appSep docParenL
-- TODO: we don't make consistent use of these (yet). However, I think the
-- most readable approach overall might be something else: define
-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.
-- I think those two would make the usage most readable.
-- lit "(" and appSep (lit "(") are understandable and short without
-- introducing a new top-level binding for all types of parentheses.
docParenL :: ToBriDocM BriDocNumbered
docParenL = docLit $ Text.pack "("
docParenR :: ToBriDocM BriDocNumbered
docParenR = docLit $ Text.pack ")"
docParenHashLSep :: ToBriDocM BriDocNumbered
docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
docParenHashRSep :: ToBriDocM BriDocNumbered
docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
docBracketL :: ToBriDocM BriDocNumbered
docBracketL = docLit $ Text.pack "["
docBracketR :: ToBriDocM BriDocNumbered
docBracketR = docLit $ Text.pack "]"
docTick :: ToBriDocM BriDocNumbered
docTick = docLit $ Text.pack "'"
docNodeAnnKW
:: Data.Data.Data ast
=> Located ast
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docNodeAnnKW ast kw bdm =
docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm
docNodeMoveToKWDP
:: Data.Data.Data ast
=> Located ast
-> AnnKeywordId
-> Bool
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm
class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast)
=> Located ast
-> a
-> a
docWrapNodePrior :: ( Data.Data.Data ast)
=> Located ast
-> a
-> a
docWrapNodeRest :: ( Data.Data.Data ast)
=> Located ast
-> a
-> a
instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNode ast bdm = do
bd <- bdm
i1 <- allocNodeIndex
i2 <- allocNodeIndex
return
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ (,) i2
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd
docWrapNodePrior ast bdm = do
bd <- bdm
i1 <- allocNodeIndex
return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
docWrapNodeRest ast bdm = do
bd <- bdm
i2 <- allocNodeIndex
return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
docWrapNode ast bdms = case bdms of
[] -> []
[bd] -> [docWrapNode ast bd]
(bd1 : bdR) | (bdN : bdM) <- reverse bdR ->
[docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]
_ -> error "cannot happen (TM)"
docWrapNodePrior ast bdms = case bdms of
[] -> []
[bd] -> [docWrapNodePrior ast bd]
(bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR
docWrapNodeRest ast bdms = case reverse bdms of
[] -> []
(bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
docWrapNode ast bdsm = do
bds <- bdsm
case bds of
[] -> return [] -- TODO: this might be bad. maybe. then again, not really. well.
[bd] -> do
bd' <- docWrapNode ast (return bd)
return [bd']
(bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do
bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN)
return $ [bd1'] ++ reverse bdM ++ [bdN']
_ -> error "cannot happen (TM)"
docWrapNodePrior ast bdsm = do
bds <- bdsm
case bds of
[] -> return []
(bd1 : bdR) -> do
bd1' <- docWrapNodePrior ast (return bd1)
return (bd1' : bdR)
docWrapNodeRest ast bdsm = do
bds <- bdsm
case reverse bds of
[] -> return []
(bdN : bdR) -> do
bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse (bdN' : bdR)
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
docWrapNode ast bdsm = do
bds <- bdsm
case Seq.viewl bds of
Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
bd1 Seq.:< rest -> case Seq.viewr rest of
Seq.EmptyR -> do
bd1' <- docWrapNode ast (return bd1)
return $ Seq.singleton bd1'
bdM Seq.:> bdN -> do
bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN)
return $ (bd1' Seq.<| bdM) Seq.|> bdN'
docWrapNodePrior ast bdsm = do
bds <- bdsm
case Seq.viewl bds of
Seq.EmptyL -> return Seq.empty
bd1 Seq.:< bdR -> do
bd1' <- docWrapNodePrior ast (return bd1)
return $ bd1' Seq.<| bdR
docWrapNodeRest ast bdsm = do
bds <- bdsm
case Seq.viewr bds of
Seq.EmptyR -> return Seq.empty
bdR Seq.:> bdN -> do
bdN' <- docWrapNodeRest ast (return bdN)
return $ bdR Seq.|> bdN'
instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where
docWrapNode ast stuffM = do
(bds, bd, x) <- stuffM
if null bds
then do
bd' <- docWrapNode ast (return bd)
return (bds, bd', x)
else do
bds' <- docWrapNodePrior ast (return bds)
bd' <- docWrapNodeRest ast (return bd)
return (bds', bd', x)
docWrapNodePrior ast stuffM = do
(bds, bd, x) <- stuffM
bds' <- docWrapNodePrior ast (return bds)
return (bds', bd, x)
docWrapNodeRest ast stuffM = do
(bds, bd, x) <- stuffM
bd' <- docWrapNodeRest ast (return bd)
return (bds, bd', x)
docPar
:: ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docPar lineM indentedM = do
line <- lineM
indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented
docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
docEnsureIndent
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
unknownNodeError
:: Data.Data.Data ast
=> String
-> GenLocated GHC.SrcSpan ast
-> ToBriDocM BriDocNumbered
unknownNodeError infoStr ast = do
mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]
spacifyDocs [] = []
spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
briDocMToPPM :: ToBriDocM a -> PPMLocal a
briDocMToPPM m = do
(x, errs, debugs) <- briDocMToPPMInner m
mTell debugs
mTell errs
return x
briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
briDocMToPPMInner m = do
readers <- MultiRWSS.mGetRawR
let
((x, errs), debugs) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ m
pure (x, errs, debugs)
docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)
docSharedWrapper f x = return <$> f x

1086
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

File diff suppressed because it is too large Load Diff

224
source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -1,224 +0,0 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.IE where
import qualified Data.List.Extra
import qualified Data.Text as Text
import GHC
( AnnKeywordId(..)
, GenLocated(L)
, Located
, ModuleName
, moduleNameString
, unLoc
)
import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> Located name
prepareName = ieLWrappedName
layoutIE :: ToBriDoc IE
layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
IEVar _ x -> layoutWrapped lie x
IEThingAbs _ x -> layoutWrapped lie x
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x (IEWildcard _) _ _ ->
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x _ ns _ -> do
hasComments <- orM
(hasCommentsBetween lie AnnOpenP AnnCloseP
: hasAnyCommentsBelow x
: map hasAnyCommentsBelow ns
)
let sortedNs = List.sortOn wrappedNameToText ns
runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
$ [layoutWrapped lie x, docLit $ Text.pack "("]
++ intersperse docCommaSep (map nameDoc sortedNs)
++ [docParenR]
addAlternative
$ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular
$ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
where
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty = docSetBaseY $ docLines
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]
, docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
, docParenR
]
layoutItems (FirstLast n1 nMs nN) =
docSetBaseY
$ docLines
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs
++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module"
, docSeparator
, docLit . Text.pack . moduleNameString $ unLoc n
]
_ -> docEmpty
where
layoutWrapped _ = \case
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
L _ (IEPattern n) -> do
name <- lrdrNameToTextAnn n
docLit $ Text.pack "pattern " <> name
L _ (IEType n) -> do
name <- lrdrNameToTextAnn n
docLit $ Text.pack "type " <> name
data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- Helper function to deal with Located lists of LIEs.
-- In particular this will also associate documentation
-- from the located list that actually belongs to the last IE.
-- It also adds docCommaSep to all but the first element
-- This configuration allows both vertical and horizontal
-- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
:: SortItemsFlag
-> Located [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie]
let
sortedLies =
[ items
| group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
, items <- mergeGroup group
]
let
ieDocs = fmap layoutIE $ case shouldSort of
ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies
ieCommaDocs <-
docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
FirstLastEmpty -> []
FirstLastSingleton ie -> [ie]
FirstLast ie1 ieMs ieN ->
[ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
pure $ fmap pure ieCommaDocs -- returned shared nodes
where
mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
mergeGroup [] = []
mergeGroup items@[_] = items
mergeGroup items = if
| all isProperIEThing items -> [List.foldl1' thingFolder items]
| all isIEVar items -> [List.foldl1' thingFolder items]
| otherwise -> items
-- proper means that if it is a ThingWith, it does not contain a wildcard
-- (because I don't know what a wildcard means if it is not already a
-- IEThingAll).
isProperIEThing :: LIE GhcPs -> Bool
isProperIEThing = \case
L _ (IEThingAbs _ _wn) -> True
L _ (IEThingAll _ _wn) -> True
L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True
_ -> False
isIEVar :: LIE GhcPs -> Bool
isIEVar = \case
L _ IEVar{} -> True
_ -> False
thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
thingFolder l1@(L _ IEVar{}) _ = l1
thingFolder l1@(L _ IEThingAll{}) _ = l1
thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 (L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
= L
l
(IEThingWith
x
wn
NoIEWildcard
(consItems1 ++ consItems2)
(fieldLbls1 ++ fieldLbls2)
)
thingFolder _ _ =
error "thingFolder should be exhaustive because we have a guard above"
-- Builds a complete layout for the given located
-- list of LIEs. The layout provides two alternatives:
-- (item, item, ..., item)
-- ( item
-- , item
-- ...
-- , item
-- )
-- If the llies contains comments the list will
-- always expand over multiple lines, even when empty:
-- () -- no comments
-- ( -- a comment
-- )
layoutLLIEs
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies
runFilteredAlternative $ case ieDs of
[] -> do
addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
addAlternativeCond hasComments $ docPar
(docSeq [docParenLSep, docWrapNodeRest llies docEmpty])
docParenR
(ieDsH : ieDsT) -> do
addAlternativeCond (not hasComments && enableSingleline)
$ docSeq
$ [docLit (Text.pack "(")]
++ (docForceSingleline <$> ieDs)
++ [docParenR]
addAlternative
$ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
$ docLines
$ ieDsT
++ [docParenR]
-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code.
wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case
L _ (IEName n) -> lrdrNameToText n
L _ (IEPattern n) -> lrdrNameToText n
L _ (IEType n) -> lrdrNameToText n
-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code.
lieToText :: LIE GhcPs -> Text
lieToText = \case
L _ (IEVar _ wn) -> wrappedNameToText wn
L _ (IEThingAbs _ wn) -> wrappedNameToText wn
L _ (IEThingAll _ wn) -> wrappedNameToText wn
L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some
-- other clever thing.
L _ (IEModuleContents _ n) -> moduleNameToText n
L _ IEGroup{} -> Text.pack "@IEGroup"
L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where
moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)

197
source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -1,197 +0,0 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.Module where
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)
import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types
(DeltaPos(..), commentContents, deltaRow)
layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of
-- Implicit module Main
HsModule _ Nothing _ imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
-- sortedImports <- sortImports imports
-- docLines $ [layoutImport y i | (y, i) <- sortedImports]
HsModule _ (Just n) les imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports
let tn = Text.pack $ moduleNameString $ unLoc n
allowSingleLineExportList <-
mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
-- the config should not prevent single-line layout when there is no
-- export list
let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
docLines
$ docSeq
[ docNodeAnnKW lmod Nothing docEmpty
-- A pseudo node that serves merely to force documentation
-- before the node
, docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do
addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq
[ appSep $ docLit $ Text.pack "module"
, appSep $ docLit tn
, docWrapNode lmod $ appSep $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs True KeepItemsUnsorted x
, docSeparator
, docLit $ Text.pack "where"
]
addAlternative $ docLines
[ docAddBaseY BrIndentRegular $ docPar
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn])
(docSeq
[ docWrapNode lmod $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs False KeepItemsUnsorted x
, docSeparator
, docLit $ Text.pack "where"
]
)
]
]
: (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]
data CommentedImport
= EmptyLine
| IndependentComment (Comment, DeltaPos)
| ImportStatement ImportStatementRecord
instance Show CommentedImport where
show = \case
EmptyLine -> "EmptyLine"
IndependentComment _ -> "IndependentComment"
ImportStatement r ->
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
data ImportStatementRecord = ImportStatementRecord
{ commentsBefore :: [(Comment, DeltaPos)]
, commentsAfter :: [(Comment, DeltaPos)]
, importStatement :: ImportDecl GhcPs
}
instance Show ImportStatementRecord where
show r =
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
transformToCommentedImport
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
transformToCommentedImport is = do
nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do
annotionMay <- astAnn i
pure (annotionMay, rawImport)
let
convertComment (c, DP (y, x)) =
replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
accumF
:: [(Comment, DeltaPos)]
-> (Maybe Annotation, ImportDecl GhcPs)
-> ([(Comment, DeltaPos)], [CommentedImport])
accumF accConnectedComm (annMay, decl) = case annMay of
Nothing ->
( []
, [ ImportStatement ImportStatementRecord
{ commentsBefore = []
, commentsAfter = []
, importStatement = decl
}
]
)
Just ann ->
let
blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1
(newAccumulator, priorComments') =
List.span ((== 0) . deltaRow . snd) (annPriorComments ann)
go
:: [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)]
-> ([CommentedImport], [(Comment, DeltaPos)], Int)
go acc [] = ([], acc, 0)
go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
go acc ((c1, DP (y, x)) : xs) =
( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
, (c1, DP (1, x)) : acc
, 0
)
(convertedIndependentComments, beforeComments, initialBlanks) =
if blanksBeforeImportDecl /= 0
then (convertComment =<< priorComments', [], 0)
else go [] (reverse priorComments')
in
( newAccumulator
, convertedIndependentComments
++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine
++ [ ImportStatement ImportStatementRecord
{ commentsBefore = beforeComments
, commentsAfter = accConnectedComm
, importStatement = decl
}
]
)
let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations
pure $ join $ (convertComment =<< finalAcc) : finalList
sortCommentedImports :: [CommentedImport] -> [CommentedImport]
sortCommentedImports =
unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify
where
unpackImports :: [CommentedImport] -> [CommentedImport]
unpackImports xs = xs >>= \case
l@EmptyLine -> [l]
l@IndependentComment{} -> [l]
ImportStatement r ->
map IndependentComment (commentsBefore r) ++ [ImportStatement r]
mergeGroups
:: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]
mergeGroups xs = xs >>= \case
Left x -> [x]
Right y -> ImportStatement <$> y
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
sortGroups =
List.sortOn (moduleNameString . unLoc . ideclName . importStatement)
groupify
:: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]]
groupify cs = go [] cs
where
go [] = \case
(l@EmptyLine : rest) -> Left l : go [] rest
(l@IndependentComment{} : rest) -> Left l : go [] rest
(ImportStatement r : rest) -> go [r] rest
[] -> []
go acc = \case
(l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest
(l@IndependentComment{} : rest) ->
Left l : Right (reverse acc) : go [] rest
(ImportStatement r : rest) -> go (r : acc) rest
[] -> [Right (reverse acc)]
commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
commentedImportsToDoc = \case
EmptyLine -> docLitS ""
IndependentComment c -> commentToDoc c
ImportStatement r -> docSeq
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
where
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)

10
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
View File

@ -1,10 +0,0 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Types
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))

635
source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -1,635 +0,0 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.Type where
import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L))
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import GHC.Utils.Outputable (ftext, showSDocUnsafe)
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast)
layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of
IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
NotPromoted -> docWrapNode name $ docLit t
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt
[ let open = docLit $ Text.pack "forall"
in docSeq ([open] ++ tyVarDocLineList)
, docPar
(docLit (Text.pack "forall"))
(docLines $ tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname]
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit $ Text.pack ")"
]
)
]
contextDoc = case cntxtDocs of
[] -> docLit $ Text.pack "()"
[x] -> x
_ -> docAlt
[ let
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list =
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close])
, let
open = docCols
ColTyOpPrefix
[docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
in docPar open $ docLines $ list ++ [close]
]
docAlt
-- :: forall a b c . (Foo a b c) => a b -> c
[ docSeq
[ if null bndrs
then docEmpty
else
let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])
, docForceSingleline contextDoc
, docLit $ Text.pack " => "
, docForceSingleline typeDoc
]
-- :: forall a b c
-- . (Foo a b c)
-- => a b
-- -> c
, docPar
forallDoc
(docLines
[ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3) $ contextDoc
]
, docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
]
)
]
HsForAllTy _ hsf typ2 -> do
let bndrs = getBinders hsf
typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
docAlt
-- forall x . x
[ docSeq
[ if null bndrs
then docEmpty
else
let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open] ++ tyVarDocLineList ++ [close])
, docForceSingleline $ return $ typeDoc
]
-- :: forall x
-- . x
, docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
)
-- :: forall
-- (x :: *)
-- . x
, docPar
(docLit (Text.pack "forall"))
(docLines
$ (tyVarDocs <&> \case
(tname, Nothing) ->
docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname]
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit $ Text.pack ")"
]
)
++ [ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
]
)
]
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let
contextDoc = docWrapNode lcntxts $ case cntxtDocs of
[] -> docLit $ Text.pack "()"
[x] -> x
_ -> docAlt
[ let
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list =
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close])
, let
open = docCols
ColTyOpPrefix
[docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]
in docPar open $ docLines $ list ++ [close]
]
let
maybeForceML = case typ1 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
docAlt
-- (Foo a b c) => a b -> c
[ docSeq
[ docForceSingleline contextDoc
, docLit $ Text.pack " => "
, docForceSingleline typeDoc
]
-- (Foo a b c)
-- => a b
-- -> c
, docPar
(docForceSingleline contextDoc)
(docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
]
)
]
HsFunTy _ _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
hasComments <- hasAnyCommentsBelow ltype
docAlt
$ [ docSeq
[ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2
]
| not hasComments
]
++ [ docPar
(docNodeAnnKW ltype Nothing typeDoc1)
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2
]
)
]
HsParTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack "("
, docForceSingleline typeDoc1
, docLit $ Text.pack ")"
]
, docPar
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]
)
(docLit $ Text.pack ")")
]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let
gather
:: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1
docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead
: (docRest >>= \d -> [docSeparator, docForceSingleline d])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
HsAppTy _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
docAlt
[ docSeq
[docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
]
HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack "["
, docForceSingleline typeDoc1
, docLit $ Text.pack "]"
]
, docPar
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]
)
(docLit $ Text.pack "]")
]
HsTupleTy _ tupleSort typs -> case tupleSort of
HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple
HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple
where
unboxed = if null typs
then error "brittany internal error: unboxed unit"
else unboxedL
simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()"
simpleL = do
docs <- docSharedWrapper layoutType `mapM` typs
let
end = docLit $ Text.pack ")"
lines =
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt
[ docSeq
$ [docLit $ Text.pack "("]
++ docWrapNodeRest ltype commaDocs
++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in
docPar
(docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end])
]
unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs
let
start = docParenHashLSep
end = docParenHashRSep
docAlt
[ docSeq
$ [start]
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end]
, let
line1 = docCols ColTyOpPrefix [start, head docs]
lines =
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
in docPar
(docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ lines ++ [end])
]
HsOpTy{} -> -- TODO
briDocByExactInlineOnly "HsOpTy{}" ltype
-- HsOpTy typ1 opName typ2 -> do
-- -- TODO: these need some proper fixing. precedences don't add up.
-- -- maybe the parser just returns some trivial right recursion
-- -- parse result for any type level operators.
-- -- need to check how things are handled on the expression level.
-- let opStr = lrdrNameToText opName
-- let opLen = Text.length opStr
-- layouter1@(Layouter desc1 _ _) <- layoutType typ1
-- layouter2@(Layouter desc2 _ _) <- layoutType typ2
-- let line = do -- Maybe
-- l1 <- _ldesc_line desc1
-- l2 <- _ldesc_line desc2
-- let len1 = _lColumns_min l1
-- let len2 = _lColumns_min l2
-- let len = 2 + opLen + len1 + len2
-- return $ LayoutColumns
-- { _lColumns_key = ColumnKeyUnique
-- , _lColumns_lengths = [len]
-- , _lColumns_min = len
-- }
-- let block = do -- Maybe
-- rol1 <- descToBlockStart desc1
-- (min2, max2) <- descToMinMax (1+opLen) desc2
-- let (minR, maxR) = case descToBlockMinMax desc1 of
-- Nothing -> (min2, max2)
-- Just (min1, max1) -> (max min1 min2, max max1 max2)
-- return $ BlockDesc
-- { _bdesc_blockStart = rol1
-- , _bdesc_min = minR
-- , _bdesc_max = maxR
-- , _bdesc_opIndentFloatUp = Just (1+opLen)
-- }
-- return $ Layouter
-- { _layouter_desc = LayoutDesc
-- { _ldesc_line = line
-- , _ldesc_block = block
-- }
-- , _layouter_func = \params -> do
-- remaining <- getCurRemaining
-- let allowSameLine = _params_sepLines params /= SepLineTypeOp
-- case line of
-- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do
-- applyLayouterRestore layouter1 defaultParams
-- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " "
-- applyLayouterRestore layouter2 defaultParams
-- _ -> do
-- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params
-- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2
-- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams
-- layoutWriteNewline
-- layoutWriteAppend $ opStr <> Text.pack " "
-- layoutWriteEnsureBlockPlusN downIndent
-- applyLayouterRestore layouter2 defaultParams
-- { _params_sepLines = SepLineTypeOp
-- , _params_opIndent = Just downIndent
-- }
-- , _layouter_ast = ltype
-- }
HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack
("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1
]
, docPar
(docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
]
)
]
-- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
kindDoc1 <- docSharedWrapper layoutType kind1
hasParens <- hasAnnKeyword ltype AnnOpenP
docAlt
[ if hasParens
then docSeq
[ docLit $ Text.pack "("
, docForceSingleline typeDoc1
, docSeparator
, docLit $ Text.pack "::"
, docSeparator
, docForceSingleline kindDoc1
, docLit $ Text.pack ")"
]
else docSeq
[ docForceSingleline typeDoc1
, docSeparator
, docLit $ Text.pack "::"
, docSeparator
, docForceSingleline kindDoc1
]
, if hasParens
then docLines
[ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 3) $ typeDoc1
]
, docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1
]
, (docLit $ Text.pack ")")
]
else docPar
typeDoc1
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1
]
)
]
HsBangTy{} -> -- TODO
briDocByExactInlineOnly "HsBangTy{}" ltype
-- HsBangTy bang typ1 -> do
-- let bangStr = case bang of
-- HsSrcBang _ unpackness strictness ->
-- (++)
-- (case unpackness of
-- SrcUnpack -> "{-# UNPACK -#} "
-- SrcNoUnpack -> "{-# NOUNPACK -#} "
-- NoSrcUnpack -> ""
-- )
-- (case strictness of
-- SrcLazy -> "~"
-- SrcStrict -> "!"
-- NoSrcStrict -> ""
-- )
-- let bangLen = length bangStr
-- layouter@(Layouter desc _ _) <- layoutType typ1
-- let line = do -- Maybe
-- l <- _ldesc_line desc
-- let len = bangLen + _lColumns_min l
-- return $ LayoutColumns
-- { _lColumns_key = ColumnKeyUnique
-- , _lColumns_lengths = [len]
-- , _lColumns_min = len
-- }
-- let block = do -- Maybe
-- rol <- descToBlockStart desc
-- (minR,maxR) <- descToBlockMinMax desc
-- return $ BlockDesc
-- { _bdesc_blockStart = rol
-- , _bdesc_min = minR
-- , _bdesc_max = maxR
-- , _bdesc_opIndentFloatUp = Nothing
-- }
-- return $ Layouter
-- { _layouter_desc = LayoutDesc
-- { _ldesc_line = line
-- , _ldesc_block = block
-- }
-- , _layouter_func = \_params -> do
-- remaining <- getCurRemaining
-- case line of
-- Just (LayoutColumns _ _ m) | m <= remaining -> do
-- layoutWriteAppend $ Text.pack $ bangStr
-- applyLayouterRestore layouter defaultParams
-- _ -> do
-- layoutWriteAppend $ Text.pack $ bangStr
-- layoutWritePostCommentsRestore ltype
-- applyLayouterRestore layouter defaultParams
-- , _layouter_ast = ltype
-- }
HsSpliceTy{} -> -- TODO
briDocByExactInlineOnly "HsSpliceTy{}" ltype
HsDocTy{} -> -- TODO
briDocByExactInlineOnly "HsDocTy{}" ltype
HsRecTy{} -> -- TODO
briDocByExactInlineOnly "HsRecTy{}" ltype
HsExplicitListTy _ _ typs -> do
typDocs <- docSharedWrapper layoutType `mapM` typs
hasComments <- hasAnyCommentsBelow ltype
let specialCommaSep = appSep $ docLit $ Text.pack " ,"
docAlt
[ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
++ [docLit $ Text.pack "]"]
, case splitFirstLast typDocs of
FirstLastEmpty -> docSeq
[ docLit $ Text.pack "'["
, docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]"
]
FirstLastSingleton e -> docAlt
[ docSeq
[ docLit $ Text.pack "'["
, docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e
, docLit $ Text.pack "]"
]
, docSetBaseY $ docLines
[ docSeq
[ docLit $ Text.pack "'["
, docSeparator
, docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e
]
, docLit $ Text.pack " ]"
]
]
FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
++ [docLit $ Text.pack " ]"]
addAlternative
$ let
start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
lineN = docCols
ColList
[specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
]
HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
HsTyLit _ lit -> case lit of
HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsNumTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> docLit $ Text.pack "_"
HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do
if isUnicode
then docLit $ Text.pack "\x2605" -- Unicode star
else docLit $ Text.pack "*"
XHsType{} -> error "brittany internal error: XHsType"
HsAppKindTy _ ty kind -> do
t <- docSharedWrapper layoutType ty
k <- docSharedWrapper layoutType kind
docAlt
[ docSeq
[ docForceSingleline t
, docSeparator
, docLit $ Text.pack "@"
, docForceSingleline k
]
, docPar t (docSeq [docLit $ Text.pack "@", k])
]
layoutTyVarBndrs
:: [LHsTyVarBndr () GhcPs]
-> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]
layoutTyVarBndrs = mapM $ \case
(L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ _ lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
-- there is no specific reason this returns a list instead of a single
-- BriDoc node.
processTyVarBndrsSingleline
:: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]
processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
(tname, Nothing) -> [docSeparator, docLit tname]
(tname, Just doc) ->
[ docSeparator
, docLit $ Text.pack "(" <> tname <> Text.pack " :: "
, docForceSingleline $ doc
, docLit $ Text.pack ")"
]
getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass]
getBinders x = case x of
HsForAllVis _ b -> b
HsForAllInvis _ b -> fmap withoutSpecificity b
XHsForAllTelescope _ -> []
withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass
withoutSpecificity = fmap $ \case
UserTyVar a _ c -> UserTyVar a () c
KindedTyVar a _ c d -> KindedTyVar a () c d
XTyVarBndr a -> XTyVarBndr a

316
source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
View File

@ -1,316 +0,0 @@
{-# OPTIONS_GHC -Wno-implicit-prelude #-}
module Language.Haskell.Brittany.Internal.ParseModule where
import qualified Control.Monad as Monad
import qualified Control.Monad.IO.Class as IO
import qualified Control.Monad.Trans.Except as Except
import qualified GHC
import qualified GHC.ByteOrder
import qualified GHC.Data.Bag
import qualified GHC.Data.StringBuffer
import qualified GHC.Driver.Session
import qualified GHC.Parser.Header
import qualified GHC.Platform
import qualified GHC.Settings
import qualified GHC.Types.SrcLoc
import qualified GHC.Utils.Error
import qualified GHC.Utils.Fingerprint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-- | Parses a Haskell module. Although this nominally requires IO, it is
-- morally pure. It should have no observable effects.
parseModule
:: IO.MonadIO io
=> [String]
-> FilePath
-> (GHC.Driver.Session.DynFlags -> io (Either String a))
-> String
-> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
let
dynFlags1 = GHC.Driver.Session.gopt_set
-- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both
-- of those modes have trouble parsing safe imports (@import safe ...@).
-- Neither passing in @"-XUnsafe"@ as a command line argument nor having
-- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
initialDynFlags
{ GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe
}
GHC.Driver.Session.Opt_KeepRawTokenStream
(dynFlags2, leftovers1, _) <-
GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1
$ fmap GHC.Types.SrcLoc.noLoc arguments1
handleLeftovers leftovers1
let
stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string
arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath
(dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma
dynFlags2
arguments2
handleLeftovers leftovers2
dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3
let
parseResult =
ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
case parseResult of
Left errorMessages -> handleErrorMessages errorMessages
Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult)
handleLeftovers
:: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()
handleLeftovers leftovers =
Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show
(fmap GHC.Types.SrcLoc.unLoc leftovers)
handleErrorMessages
:: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a
handleErrorMessages =
Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList
initialDynFlags :: GHC.Driver.Session.DynFlags
initialDynFlags = GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig
initialSettings :: GHC.Driver.Session.Settings
initialSettings = GHC.Driver.Session.Settings
{ GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion
, GHC.Driver.Session.sFileSettings = initialFileSettings
, GHC.Driver.Session.sTargetPlatform = initialTargetPlatform
, GHC.Driver.Session.sToolSettings = initialToolSettings
, GHC.Driver.Session.sPlatformMisc = initialPlatformMisc
, GHC.Driver.Session.sPlatformConstants = initialPlatformConstants
, GHC.Driver.Session.sRawSettings = []
}
initialFileSettings :: GHC.Driver.Session.FileSettings
initialFileSettings = GHC.Driver.Session.FileSettings
{ GHC.Driver.Session.fileSettings_ghciUsagePath = ""
, GHC.Driver.Session.fileSettings_ghcUsagePath = ""
, GHC.Driver.Session.fileSettings_globalPackageDatabase = ""
, GHC.Driver.Session.fileSettings_tmpDir = ""
, GHC.Driver.Session.fileSettings_toolDir = Nothing
, GHC.Driver.Session.fileSettings_topDir = ""
}
initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion
initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion
{ GHC.Driver.Session.ghcNameVersion_programName = ""
, GHC.Driver.Session.ghcNameVersion_projectVersion = ""
}
initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
initialPlatformMisc = GHC.Driver.Session.PlatformMisc
{ GHC.Driver.Session.platformMisc_ghcDebugged = False
, GHC.Driver.Session.platformMisc_ghcRTSWays = ""
, GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False
, GHC.Driver.Session.platformMisc_ghcThreaded = False
, GHC.Driver.Session.platformMisc_ghcWithInterpreter = False
, GHC.Driver.Session.platformMisc_ghcWithSMP = False
, GHC.Driver.Session.platformMisc_libFFI = False
, GHC.Driver.Session.platformMisc_llvmTarget = ""
, GHC.Driver.Session.platformMisc_targetPlatformString = ""
}
initialLlvmConfig :: GHC.Driver.Session.LlvmConfig
initialLlvmConfig = GHC.Driver.Session.LlvmConfig
{ GHC.Driver.Session.llvmPasses = []
, GHC.Driver.Session.llvmTargets = []
}
initialPlatformConstants :: GHC.Settings.PlatformConstants
initialPlatformConstants = GHC.Settings.PlatformConstants
{ GHC.Settings.pc_AP_STACK_SPLIM = 0
, GHC.Settings.pc_BITMAP_BITS_SHIFT = 0
, GHC.Settings.pc_BLOCK_SIZE = 0
, GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0
, GHC.Settings.pc_CINT_SIZE = 0
, GHC.Settings.pc_CLONG_LONG_SIZE = 0
, GHC.Settings.pc_CLONG_SIZE = 0
, GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0
, GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False
, GHC.Settings.pc_ILDV_CREATE_MASK = 0
, GHC.Settings.pc_ILDV_STATE_CREATE = 0
, GHC.Settings.pc_ILDV_STATE_USE = 0
, GHC.Settings.pc_LDV_SHIFT = 0
, GHC.Settings.pc_MAX_CHARLIKE = 0
, GHC.Settings.pc_MAX_Double_REG = 0
, GHC.Settings.pc_MAX_Float_REG = 0
, GHC.Settings.pc_MAX_INTLIKE = 0
, GHC.Settings.pc_MAX_Long_REG = 0
, GHC.Settings.pc_MAX_Real_Double_REG = 0
, GHC.Settings.pc_MAX_Real_Float_REG = 0
, GHC.Settings.pc_MAX_Real_Long_REG = 0
, GHC.Settings.pc_MAX_Real_Vanilla_REG = 0
, GHC.Settings.pc_MAX_Real_XMM_REG = 0
, GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0
, GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0
, GHC.Settings.pc_MAX_Vanilla_REG = 0
, GHC.Settings.pc_MAX_XMM_REG = 0
, GHC.Settings.pc_MIN_CHARLIKE = 0
, GHC.Settings.pc_MIN_INTLIKE = 0
, GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0
, GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0
, GHC.Settings.pc_OFFSET_bdescr_blocks = 0
, GHC.Settings.pc_OFFSET_bdescr_flags = 0
, GHC.Settings.pc_OFFSET_bdescr_free = 0
, GHC.Settings.pc_OFFSET_bdescr_start = 0
, GHC.Settings.pc_OFFSET_Capability_r = 0
, GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0
, GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0
, GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0
, GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_link = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0
, GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
, GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0
, GHC.Settings.pc_OFFSET_stgGCEnter1 = 0
, GHC.Settings.pc_OFFSET_stgGCFun = 0
, GHC.Settings.pc_OFFSET_StgHeader_ccs = 0
, GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0
, GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0
, GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0
, GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
, GHC.Settings.pc_OFFSET_StgStack_sp = 0
, GHC.Settings.pc_OFFSET_StgStack_stack = 0
, GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0
, GHC.Settings.pc_OFFSET_StgTSO_cccs = 0
, GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0
, GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0
, GHC.Settings.pc_PROF_HDR_SIZE = 0
, GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0
, GHC.Settings.pc_REP_CostCentreStack_scc_count = 0
, GHC.Settings.pc_REP_StgEntCounter_allocd = 0
, GHC.Settings.pc_REP_StgEntCounter_allocs = 0
, GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0
, GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0
, GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0
, GHC.Settings.pc_RESERVED_STACK_WORDS = 0
, GHC.Settings.pc_SIZEOF_CostCentreStack = 0
, GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0
, GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0
, GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
, GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
, GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0
, GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
, GHC.Settings.pc_STD_HDR_SIZE = 0
, GHC.Settings.pc_TAG_BITS = 0
, GHC.Settings.pc_TICKY_BIN_COUNT = 0
, GHC.Settings.pc_WORD_SIZE = 0
}
initialPlatformMini :: GHC.Settings.PlatformMini
initialPlatformMini = GHC.Settings.PlatformMini
{ GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64
, GHC.Settings.platformMini_os = GHC.Platform.OSLinux
}
initialTargetPlatform :: GHC.Settings.Platform
initialTargetPlatform = GHC.Settings.Platform
{ GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian
, GHC.Settings.platformHasGnuNonexecStack = False
, GHC.Settings.platformHasIdentDirective = False
, GHC.Settings.platformHasSubsectionsViaSymbols = False
, GHC.Settings.platformIsCrossCompiling = False
, GHC.Settings.platformLeadingUnderscore = False
, GHC.Settings.platformMini = initialPlatformMini
, GHC.Settings.platformTablesNextToCode = False
, GHC.Settings.platformUnregisterised = False
, GHC.Settings.platformWordSize = GHC.Platform.PW8
}
initialToolSettings :: GHC.Settings.ToolSettings
initialToolSettings = GHC.Settings.ToolSettings
{ GHC.Settings.toolSettings_ccSupportsNoPie = False
, GHC.Settings.toolSettings_extraGccViaCFlags = []
, GHC.Settings.toolSettings_ldIsGnuLd = False
, GHC.Settings.toolSettings_ldSupportsBuildId = False
, GHC.Settings.toolSettings_ldSupportsCompactUnwind = False
, GHC.Settings.toolSettings_ldSupportsFilelist = False
, GHC.Settings.toolSettings_opt_a = []
, GHC.Settings.toolSettings_opt_c = []
, GHC.Settings.toolSettings_opt_cxx = []
, GHC.Settings.toolSettings_opt_F = []
, GHC.Settings.toolSettings_opt_i = []
, GHC.Settings.toolSettings_opt_l = []
, GHC.Settings.toolSettings_opt_L = []
, GHC.Settings.toolSettings_opt_lc = []
, GHC.Settings.toolSettings_opt_lcc = []
, GHC.Settings.toolSettings_opt_lm = []
, GHC.Settings.toolSettings_opt_lo = []
, GHC.Settings.toolSettings_opt_P = []
, GHC.Settings.toolSettings_opt_P_fingerprint =
GHC.Utils.Fingerprint.fingerprint0
, GHC.Settings.toolSettings_opt_windres = []
, GHC.Settings.toolSettings_pgm_a = ("", [])
, GHC.Settings.toolSettings_pgm_ar = ""
, GHC.Settings.toolSettings_pgm_c = ""
, GHC.Settings.toolSettings_pgm_dll = ("", [])
, GHC.Settings.toolSettings_pgm_F = ""
, GHC.Settings.toolSettings_pgm_i = ""
, GHC.Settings.toolSettings_pgm_install_name_tool = ""
, GHC.Settings.toolSettings_pgm_l = ("", [])
, GHC.Settings.toolSettings_pgm_L = ""
, GHC.Settings.toolSettings_pgm_lc = ("", [])
, GHC.Settings.toolSettings_pgm_lcc = ("", [])
, GHC.Settings.toolSettings_pgm_libtool = ""
, GHC.Settings.toolSettings_pgm_lm = ("", [])
, GHC.Settings.toolSettings_pgm_lo = ("", [])
, GHC.Settings.toolSettings_pgm_otool = ""
, GHC.Settings.toolSettings_pgm_P = ("", [])
, GHC.Settings.toolSettings_pgm_ranlib = ""
, GHC.Settings.toolSettings_pgm_T = ""
, GHC.Settings.toolSettings_pgm_windres = ""
}

102
source/library/Language/Haskell/Brittany/Internal/Prelude.hs
View File

@ -1,5 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.Brittany.Internal.Prelude
( module E
, module Language.Haskell.Brittany.Internal.Prelude
) where
import Control.Applicative as E (Alternative(..), Applicative(..))
@ -75,8 +78,6 @@ import Data.List as E
, mapAccumR
, maximum
, minimum
, notElem
, nub
, null
, partition
, repeat
@ -110,7 +111,7 @@ import Data.Monoid as E
import Data.Ord as E (Down(..), Ordering(..), comparing)
import Data.Proxy as E (Proxy(..))
import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator)
import Data.Semigroup as E ((<>), Semigroup(..))
import Data.Semigroup as E ((<>), Semigroup(..), Last(Last))
import Data.Sequence as E (Seq)
import Data.Set as E (Set)
import Data.String as E (String)
@ -135,6 +136,7 @@ import Foreign.ForeignPtr as E (ForeignPtr)
import Foreign.Storable as E (Storable)
import GHC.Exts as E (Constraint)
import GHC.Hs.Extension as E (GhcPs)
import GHC.Stack as E (HasCallStack)
import GHC.Types.Name.Reader as E (RdrName)
import Prelude as E
( ($)
@ -143,7 +145,6 @@ import Prelude as E
, (++)
, (.)
, (<$>)
, Bounded(..)
, Double
, Enum(..)
, Eq(..)
@ -163,10 +164,8 @@ import Prelude as E
, and
, any
, const
, curry
, error
, flip
, foldl
, foldr
, foldr1
, fromIntegral
@ -192,3 +191,94 @@ import Prelude as E
)
import System.IO as E (IO, hFlush, stdout)
import Text.Read as E (readMaybe)
import qualified Data.Strict.Maybe as Strict
import Control.DeepSeq (NFData, force)
import System.IO (hPutStrLn, stderr, hPutStr)
import qualified Data.Data
import GHC.Types.SrcLoc ( RealSrcLoc )
import qualified GHC.Utils.Misc
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Sequence as Seq
instance Applicative Strict.Maybe where
pure = Strict.Just
Strict.Just f <*> Strict.Just x = Strict.Just (f x)
_ <*> _ = Strict.Nothing
instance Monad Strict.Maybe where
Strict.Nothing >>= _ = Strict.Nothing
Strict.Just x >>= f = f x
instance Alternative Strict.Maybe where
empty = Strict.Nothing
x <|> Strict.Nothing = x
_ <|> x = x
traceFunctionWith
:: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
traceFunctionWith name s1 s2 f x = trace traceStr y
where
y = f x
traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
(<&!>) :: Monad m => m a -> (a -> b) -> m b
(<&!>) = flip (<$!>)
putStrErrLn :: String -> IO ()
putStrErrLn s = hPutStrLn stderr s
putStrErr :: String -> IO ()
putStrErr s = hPutStr stderr s
printErr :: Show a => a -> IO ()
printErr = putStrErrLn . show
errorIf :: Bool -> a -> a
errorIf False = id
errorIf True = error "errorIf"
errorIfNote :: Maybe String -> a -> a
errorIfNote Nothing = id
errorIfNote (Just x) = error x
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap
infixl 4 <&>
(.>) :: (a -> b) -> (b -> c) -> (a -> c)
f .> g = g . f
infixl 9 .>
evaluateDeep :: NFData a => a -> IO a
evaluateDeep = evaluate . force
instance Data.Data.Data RealSrcLoc where
-- don't traverse?
toConstr _ = GHC.Utils.Misc.abstractConstr "RealSrcLoc"
gunfold _ _ = error "gunfold"
dataTypeOf _ = GHC.Utils.Misc.mkNoRepType "RealSrcLoc"
-- TODO: move to uniplate upstream?
-- aka `transform`
transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
transformUp f = g where g = f . Uniplate.descend g
_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
_transformDown f = g where g = Uniplate.descend g . f
transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x
_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x
-- i should really put that into multistate..
mModify :: MonadMultiState s m => (s -> s) -> m ()
mModify f = mGet >>= mSet . f
tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow
:: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show

66
source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs
View File

@ -1,66 +0,0 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.Brittany.Internal.PreludeUtils where
import Control.Applicative
import Control.DeepSeq (NFData, force)
import Control.Exception.Base (evaluate)
import Control.Monad
import qualified Data.Strict.Maybe as Strict
import Debug.Trace
import Prelude
import System.IO
instance Applicative Strict.Maybe where
pure = Strict.Just
Strict.Just f <*> Strict.Just x = Strict.Just (f x)
_ <*> _ = Strict.Nothing
instance Monad Strict.Maybe where
Strict.Nothing >>= _ = Strict.Nothing
Strict.Just x >>= f = f x
instance Alternative Strict.Maybe where
empty = Strict.Nothing
x <|> Strict.Nothing = x
_ <|> x = x
traceFunctionWith
:: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
traceFunctionWith name s1 s2 f x = trace traceStr y
where
y = f x
traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
(<&!>) :: Monad m => m a -> (a -> b) -> m b
(<&!>) = flip (<$!>)
putStrErrLn :: String -> IO ()
putStrErrLn s = hPutStrLn stderr s
putStrErr :: String -> IO ()
putStrErr s = hPutStr stderr s
printErr :: Show a => a -> IO ()
printErr = putStrErrLn . show
errorIf :: Bool -> a -> a
errorIf False = id
errorIf True = error "errorIf"
errorIfNote :: Maybe String -> a -> a
errorIfNote Nothing = id
errorIfNote (Just x) = error x
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap
infixl 4 <&>
(.>) :: (a -> b) -> (b -> c) -> (a -> c)
f .> g = g . f
infixl 9 .>
evaluateDeep :: NFData a => a -> IO a
evaluateDeep = evaluate . force

346
source/library/Language/Haskell/Brittany/Internal/S1_Parsing.hs Normal file
View File

@ -0,0 +1,346 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.S1_Parsing
( parseModule
, parseModuleFromString
)
where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad
import qualified Control.Monad.Trans.Except as Except
import qualified GHC hiding ( parseModule )
import qualified GHC.ByteOrder
import qualified GHC.Data.Bag
import qualified GHC.Data.StringBuffer
import qualified GHC.Driver.Session
import qualified GHC.Parser.Header
import qualified GHC.Platform
import qualified GHC.Settings
import qualified GHC.Types.SrcLoc
import qualified GHC.Utils.Error
import qualified GHC.Utils.Fingerprint
import qualified Language.Haskell.GHC.ExactPrint.Parsers
as ExactPrint
import qualified System.IO
-- TODO why are redirecting to parseModuleFromString here?
parseModule
:: [String]
-> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a))
-> IO (Either String (GHC.ParsedSource, a))
parseModule args fp dynCheck = do
str <- System.IO.readFile fp
parseModuleFromString args fp dynCheck str
-- | Parses a Haskell module. Although this nominally requires IO, it is
-- morally pure. It should have no observable effects.
parseModuleFromString
:: [String]
-> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a))
-> String
-> IO (Either String (GHC.ParsedSource, a))
parseModuleFromString arguments1 filePath checkDynFlags string =
Except.runExceptT $ do
let dynFlags1 = GHC.Driver.Session.gopt_set
-- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both
-- of those modes have trouble parsing safe imports (@import safe ...@).
-- Neither passing in @"-XUnsafe"@ as a command line argument nor having
-- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
initialDynFlags { GHC.Driver.Session.safeHaskell = GHC.Sf_Unsafe }
GHC.Driver.Session.Opt_KeepRawTokenStream
(dynFlags2, leftovers1, _) <-
GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1
$ fmap GHC.Types.SrcLoc.noLoc arguments1
handleLeftovers leftovers1
let stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string
arguments2 =
GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath
(dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma
dynFlags2
arguments2
handleLeftovers leftovers2
dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3
let parseResult =
ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
case parseResult of
Left errorMessages -> handleErrorMessages errorMessages
-- Right parsedMod -> case ExactPrint.makeDeltaAst' parsedMod of
-- res -> pure (res, dynFlagsResult)
-- Right (L l (GHC.HsModule ann lay name xprt imp decls depr hdr)) ->
-- case ExactPrint.runTransform (ExactPrint.balanceCommentsList decls) of
-- (decls', _, _) ->
-- pure
-- ( L l (GHC.HsModule ann lay name xprt imp decls' depr hdr)
-- , dynFlagsResult
-- )
Right res -> pure (res, dynFlagsResult)
handleLeftovers
:: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()
handleLeftovers leftovers =
Control.Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show
(fmap GHC.Types.SrcLoc.unLoc leftovers)
handleErrorMessages
:: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a
handleErrorMessages =
Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList
initialDynFlags :: GHC.Driver.Session.DynFlags
initialDynFlags =
GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig
initialSettings :: GHC.Driver.Session.Settings
initialSettings = GHC.Driver.Session.Settings
{ GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion
, GHC.Driver.Session.sFileSettings = initialFileSettings
, GHC.Driver.Session.sTargetPlatform = initialTargetPlatform
, GHC.Driver.Session.sToolSettings = initialToolSettings
, GHC.Driver.Session.sPlatformMisc = initialPlatformMisc
, GHC.Driver.Session.sRawSettings = []
}
initialFileSettings :: GHC.Driver.Session.FileSettings
initialFileSettings = GHC.Driver.Session.FileSettings
{ GHC.Driver.Session.fileSettings_ghciUsagePath = ""
, GHC.Driver.Session.fileSettings_ghcUsagePath = ""
, GHC.Driver.Session.fileSettings_globalPackageDatabase = ""
, GHC.Driver.Session.fileSettings_tmpDir = ""
, GHC.Driver.Session.fileSettings_toolDir = Nothing
, GHC.Driver.Session.fileSettings_topDir = ""
}
initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion
initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion
{ GHC.Driver.Session.ghcNameVersion_programName = ""
, GHC.Driver.Session.ghcNameVersion_projectVersion = ""
}
initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
initialPlatformMisc = GHC.Driver.Session.PlatformMisc
{ GHC.Driver.Session.platformMisc_ghcRTSWays = ""
, GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False
, GHC.Driver.Session.platformMisc_ghcWithInterpreter = False
, GHC.Driver.Session.platformMisc_ghcWithSMP = False
, GHC.Driver.Session.platformMisc_libFFI = False
, GHC.Driver.Session.platformMisc_llvmTarget = ""
, GHC.Driver.Session.platformMisc_targetPlatformString = ""
}
initialLlvmConfig :: GHC.Driver.Session.LlvmConfig
initialLlvmConfig = GHC.Driver.Session.LlvmConfig
{ GHC.Driver.Session.llvmPasses = []
, GHC.Driver.Session.llvmTargets = []
}
_initialPlatformConstants :: GHC.Platform.PlatformConstants
_initialPlatformConstants = GHC.Platform.PlatformConstants
{ GHC.Platform.pc_AP_STACK_SPLIM = 0
, GHC.Platform.pc_BITMAP_BITS_SHIFT = 0
, GHC.Platform.pc_BLOCK_SIZE = 0
, GHC.Platform.pc_BLOCKS_PER_MBLOCK = 0
, GHC.Platform.pc_CINT_SIZE = 0
, GHC.Platform.pc_CLONG_LONG_SIZE = 0
, GHC.Platform.pc_CLONG_SIZE = 0
, GHC.Platform.pc_CONTROL_GROUP_CONST_291 = 0
, GHC.Platform.pc_ILDV_CREATE_MASK = 0
, GHC.Platform.pc_ILDV_STATE_CREATE = 0
, GHC.Platform.pc_ILDV_STATE_USE = 0
, GHC.Platform.pc_LDV_SHIFT = 0
, GHC.Platform.pc_MAX_CHARLIKE = 0
, GHC.Platform.pc_MAX_Double_REG = 0
, GHC.Platform.pc_MAX_Float_REG = 0
, GHC.Platform.pc_MAX_INTLIKE = 0
, GHC.Platform.pc_MAX_Long_REG = 0
, GHC.Platform.pc_MAX_Real_Double_REG = 0
, GHC.Platform.pc_MAX_Real_Float_REG = 0
, GHC.Platform.pc_MAX_Real_Long_REG = 0
, GHC.Platform.pc_MAX_Real_Vanilla_REG = 0
, GHC.Platform.pc_MAX_Real_XMM_REG = 0
, GHC.Platform.pc_MAX_SPEC_AP_SIZE = 0
, GHC.Platform.pc_MAX_SPEC_SELECTEE_SIZE = 0
, GHC.Platform.pc_MAX_Vanilla_REG = 0
, GHC.Platform.pc_MAX_XMM_REG = 0
, GHC.Platform.pc_MIN_CHARLIKE = 0
, GHC.Platform.pc_MIN_INTLIKE = 0
, GHC.Platform.pc_MIN_PAYLOAD_SIZE = 0
, GHC.Platform.pc_MUT_ARR_PTRS_CARD_BITS = 0
, GHC.Platform.pc_OFFSET_bdescr_blocks = 0
, GHC.Platform.pc_OFFSET_bdescr_flags = 0
, GHC.Platform.pc_OFFSET_bdescr_free = 0
, GHC.Platform.pc_OFFSET_bdescr_start = 0
, GHC.Platform.pc_OFFSET_Capability_r = 0
, GHC.Platform.pc_OFFSET_CostCentreStack_mem_alloc = 0
, GHC.Platform.pc_OFFSET_CostCentreStack_scc_count = 0
, GHC.Platform.pc_OFFSET_StgArrBytes_bytes = 0
, GHC.Platform.pc_OFFSET_stgEagerBlackholeInfo = 0
, GHC.Platform.pc_OFFSET_StgEntCounter_allocd = 0
, GHC.Platform.pc_OFFSET_StgEntCounter_allocs = 0
, GHC.Platform.pc_OFFSET_StgEntCounter_entry_count = 0
, GHC.Platform.pc_OFFSET_StgEntCounter_link = 0
, GHC.Platform.pc_OFFSET_StgEntCounter_registeredp = 0
, GHC.Platform.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
, GHC.Platform.pc_OFFSET_StgFunInfoExtraRev_arity = 0
, GHC.Platform.pc_OFFSET_stgGCEnter1 = 0
, GHC.Platform.pc_OFFSET_stgGCFun = 0
, GHC.Platform.pc_OFFSET_StgHeader_ccs = 0
, GHC.Platform.pc_OFFSET_StgHeader_ldvw = 0
, GHC.Platform.pc_OFFSET_StgMutArrPtrs_ptrs = 0
, GHC.Platform.pc_OFFSET_StgMutArrPtrs_size = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rCCCS = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rCurrentNursery = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rCurrentTSO = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rD1 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rD2 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rD3 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rD4 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rD5 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rD6 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rF1 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rF2 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rF3 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rF4 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rF5 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rF6 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rHp = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rHpAlloc = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rHpLim = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rL1 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR1 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR10 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR2 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR3 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR4 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR5 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR6 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR7 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR8 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rR9 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rSp = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rSpLim = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM1 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM2 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM3 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM4 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM5 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM6 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM1 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM2 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM3 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM4 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM5 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM6 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM1 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM2 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM3 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM4 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM5 = 0
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM6 = 0
, GHC.Platform.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
, GHC.Platform.pc_OFFSET_StgStack_sp = 0
, GHC.Platform.pc_OFFSET_StgStack_stack = 0
, GHC.Platform.pc_OFFSET_StgTSO_alloc_limit = 0
, GHC.Platform.pc_OFFSET_StgTSO_cccs = 0
, GHC.Platform.pc_OFFSET_StgTSO_stackobj = 0
, GHC.Platform.pc_OFFSET_StgUpdateFrame_updatee = 0
, GHC.Platform.pc_PROF_HDR_SIZE = 0
, GHC.Platform.pc_REP_CostCentreStack_mem_alloc = 0
, GHC.Platform.pc_REP_CostCentreStack_scc_count = 0
, GHC.Platform.pc_REP_StgEntCounter_allocd = 0
, GHC.Platform.pc_REP_StgEntCounter_allocs = 0
, GHC.Platform.pc_REP_StgFunInfoExtraFwd_arity = 0
, GHC.Platform.pc_REP_StgFunInfoExtraRev_arity = 0
, GHC.Platform.pc_RESERVED_C_STACK_BYTES = 0
, GHC.Platform.pc_RESERVED_STACK_WORDS = 0
, GHC.Platform.pc_SIZEOF_CostCentreStack = 0
, GHC.Platform.pc_SIZEOF_StgArrBytes_NoHdr = 0
, GHC.Platform.pc_SIZEOF_StgFunInfoExtraRev = 0
, GHC.Platform.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
, GHC.Platform.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
, GHC.Platform.pc_SIZEOF_StgSMPThunkHeader = 0
, GHC.Platform.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
, GHC.Platform.pc_STD_HDR_SIZE = 0
, GHC.Platform.pc_TAG_BITS = 0
, GHC.Platform.pc_TICKY_BIN_COUNT = 0
, GHC.Platform.pc_WORD_SIZE = 0
}
-- initialPlatformMini :: GHC.Settings.PlatformMini
-- initialPlatformMini = GHC.Settings.PlatformMini
-- { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64
-- , GHC.Settings.platformMini_os = GHC.Platform.OSLinux
-- }
initialTargetPlatform :: GHC.Settings.Platform
initialTargetPlatform = GHC.Settings.Platform
{ GHC.Settings.platformArchOS = initialArchOS
, GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian
, GHC.Settings.platformHasGnuNonexecStack = False
, GHC.Settings.platformHasIdentDirective = False
, GHC.Settings.platformHasSubsectionsViaSymbols = False
, GHC.Settings.platformIsCrossCompiling = False
, GHC.Settings.platformLeadingUnderscore = False
-- , GHC.Settings.platformMini = initialPlatformMini
, GHC.Settings.platformTablesNextToCode = False
, GHC.Settings.platformUnregisterised = False
, GHC.Settings.platformWordSize = GHC.Platform.PW8
, GHC.Settings.platform_constants = Nothing
}
initialArchOS :: GHC.Platform.ArchOS
initialArchOS = GHC.Platform.ArchOS
{ GHC.Platform.archOS_arch = GHC.Platform.ArchUnknown -- why do we need to specify these?
, GHC.Platform.archOS_OS = GHC.Platform.OSUnknown -- why do we need to specify these?
}
initialToolSettings :: GHC.Settings.ToolSettings
initialToolSettings = GHC.Settings.ToolSettings
{ GHC.Settings.toolSettings_ccSupportsNoPie = False
, GHC.Settings.toolSettings_extraGccViaCFlags = []
, GHC.Settings.toolSettings_ldIsGnuLd = False
, GHC.Settings.toolSettings_ldSupportsBuildId = False
, GHC.Settings.toolSettings_ldSupportsCompactUnwind = False
, GHC.Settings.toolSettings_ldSupportsFilelist = False
, GHC.Settings.toolSettings_opt_a = []
, GHC.Settings.toolSettings_opt_c = []
, GHC.Settings.toolSettings_opt_cxx = []
, GHC.Settings.toolSettings_opt_F = []
, GHC.Settings.toolSettings_opt_i = []
, GHC.Settings.toolSettings_opt_l = []
, GHC.Settings.toolSettings_opt_L = []
, GHC.Settings.toolSettings_opt_lc = []
, GHC.Settings.toolSettings_opt_lcc = []
, GHC.Settings.toolSettings_opt_lm = []
, GHC.Settings.toolSettings_opt_lo = []
, GHC.Settings.toolSettings_opt_P = []
, GHC.Settings.toolSettings_opt_P_fingerprint =
GHC.Utils.Fingerprint.fingerprint0
, GHC.Settings.toolSettings_opt_windres = []
, GHC.Settings.toolSettings_pgm_a = ("", [])
, GHC.Settings.toolSettings_pgm_ar = ""
, GHC.Settings.toolSettings_pgm_c = ""
, GHC.Settings.toolSettings_pgm_dll = ("", [])
, GHC.Settings.toolSettings_pgm_F = ""
, GHC.Settings.toolSettings_pgm_i = ""
, GHC.Settings.toolSettings_pgm_install_name_tool = ""
, GHC.Settings.toolSettings_pgm_l = ("", [])
, GHC.Settings.toolSettings_pgm_L = ""
, GHC.Settings.toolSettings_pgm_lc = ("", [])
, GHC.Settings.toolSettings_pgm_lcc = ("", [])
, GHC.Settings.toolSettings_pgm_libtool = ""
, GHC.Settings.toolSettings_pgm_lm = ("", [])
, GHC.Settings.toolSettings_pgm_lo = ("", [])
, GHC.Settings.toolSettings_pgm_otool = ""
, GHC.Settings.toolSettings_pgm_P = ("", [])
, GHC.Settings.toolSettings_pgm_ranlib = ""
, GHC.Settings.toolSettings_pgm_T = ""
, GHC.Settings.toolSettings_pgm_windres = ""
}

380
source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs Normal file
View File

@ -0,0 +1,380 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-- TODO92
module Language.Haskell.Brittany.Internal.S2_SplitModule
( splitModule
)
where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.Generics as SYB
import qualified GHC
import GHC ( AddEpAnn(AddEpAnn)
, Anchor(Anchor)
, EpAnn(EpAnn, EpAnnNotUsed)
, EpAnnComments
( EpaComments
, EpaCommentsBalanced
)
, EpaComment(EpaComment)
, EpaCommentTok
( EpaBlockComment
, EpaDocCommentNamed
, EpaDocCommentNext
, EpaDocCommentPrev
, EpaDocOptions
, EpaDocSection
, EpaEofComment
, EpaLineComment
)
, EpaLocation(EpaSpan)
, GenLocated(L)
, HsModule(HsModule)
, LEpaComment
, LHsDecl
, LImportDecl
, SrcSpan
( RealSrcSpan
, UnhelpfulSpan
)
, SrcSpanAnn'(SrcSpanAnn)
, anchor
, ideclName
, moduleNameString
, srcLocCol
, srcLocLine
, unLoc
)
import qualified GHC.OldList as List
import GHC.Parser.Annotation ( DeltaPos
( DifferentLine
, SameLine
)
, EpaCommentTok(EpaEofComment)
)
import GHC.Types.SrcLoc ( realSrcSpanEnd )
import qualified Language.Haskell.GHC.ExactPrint.Types
as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils
as ExactPrint
import Safe ( maximumMay )
import Language.Haskell.Brittany.Internal.Components.BriDoc
import Language.Haskell.Brittany.Internal.ToBriDoc.Module
import Language.Haskell.Brittany.Internal.Types
splitModule
:: Bool
-> GHC.ParsedSource
-> Maybe GHC.RealSrcLoc
-> FinalList ModuleElement ExactPrint.Pos
splitModule shouldReformatHead lmod posWhere = do
let L moduleSpan modl = lmod
HsModule _ _layout _name _exports imports decls _ _ = modl
(hsModAnn', finalComments) = case GHC.hsmodAnn modl of
EpAnn a modAnns (EpaCommentsBalanced prior post) ->
(EpAnn a modAnns (EpaCommentsBalanced prior []), post)
_ -> (GHC.hsmodAnn modl, [])
moduleWithoutComments =
L moduleSpan modl { GHC.hsmodAnn = hsModAnn', GHC.hsmodDecls = [] }
lastSpan <- if shouldReformatHead
then do
finalYield $ MEPrettyModuleHead moduleWithoutComments
let locBeforeImports =
maximumMay
$ [ realSrcSpanEnd $ anchor a
| L a _ <- case hsModAnn' of
EpAnn _ _ (EpaComments cs ) -> cs
EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
]
++ [ pos | Just pos <- [posWhere] ]
let (importLines, lastSpan) = finalToList $ transformToImportLine
( maybe 0 srcLocLine locBeforeImports
, maybe 1 srcLocCol locBeforeImports
)
imports
let commentedImports = groupifyImportLines importLines
sortCommentedImports commentedImports `forM_` \case
EmptyLines n ->
finalYield $ MEWhitespace $ DifferentLine n 1
SamelineComment{} ->
error "brittany internal error: splitModule SamelineComment"
NewlineComment comm -> finalYield $ MEComment comm
ImportStatement record -> do
forM_ (commentsBefore record) $ finalYield . MEComment
finalYield
$ MEImportDecl (importStatement record) (commentsSameline record)
forM_ (commentsAfter record) $ finalYield . MEComment
pure $ lastSpan
else do
finalYield $ MEExactModuleHead moduleWithoutComments
pure
$ maybe (1, 1) (ExactPrint.ss2posEnd)
$ maximumMay
$ [ GHC.anchor a
| L a _ <- GHC.priorComments $ case hsModAnn' of
EpAnn _ _ cs -> cs
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
]
++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
++ [ GHC.anchor a
| L da _ <- GHC.hsmodImports modl
, L a _ <- case GHC.ann da of
EpAnn _ _ (EpaComments l ) -> l
EpAnn _ _ (EpaCommentsBalanced _ l) -> l
EpAnnNotUsed -> []
]
++ [ span
| L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports
modl
]
spanAfterDecls <- enrichDecls lastSpan decls
enrichComms spanAfterDecls finalComments
enrichComms
:: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos
enrichComms lastSpanEnd = \case
[] -> pure lastSpanEnd
(L (Anchor span _) (EpaComment EpaEofComment _) : commRest) -> do
finalYield $ MEWhitespace $ case ExactPrint.ss2delta lastSpanEnd span of -- TODO92 move this (l-1) bit into utility function
SameLine i -> SameLine i
DifferentLine l c -> DifferentLine (l - 1) c
enrichComms (ExactPrint.ss2posEnd span) commRest
(L (Anchor span _) (EpaComment comm _) : commRest) -> do
case ExactPrint.ss2delta lastSpanEnd span of
SameLine i -> do
finalYield $ MEComment (i, comm)
DifferentLine l c -> do
finalYield $ MEWhitespace $ DifferentLine (l - 1) c
finalYield $ MEComment (0, comm)
enrichComms (ExactPrint.ss2posEnd span) commRest
enrichDecls
:: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos
enrichDecls lastSpanEnd = \case
[] -> finalPure $ lastSpanEnd
(L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest) ->
case dAnn of
EpAnn dAnchor items (EpaComments dComments) -> do
let
withoutComments =
(L (SrcSpanAnn (EpAnn dAnchor items (EpaComments [])) rlspan) decl)
commentExtract = \case
L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch
-- It would be really nice if `ExactPrint.ss2posEnd span` was
-- sufficient. But for some reason the comments are not
-- (consistently) included in the length of the anchor. I.e.
-- there are cases where a syntax tree node has an anchor from
-- pos A -> pos B. But then somewhere _below_ that node is a
-- comment that has an anchor pos B -> pos C.
-- We simply detect this here.
-- We probably do some redundant `SYB.everything` lookups
-- throughout the code now. But optimizing it is not easy, and
-- at worst it is larger constant factor on the size of the
-- input, so it isn't _that_ bad.
fixedSpanEnd = SYB.everything
max
(SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract)
decl
case ExactPrint.ss2delta lastSpanEnd span of
SameLine{} -> pure ()
DifferentLine n _ ->
finalYield $ MEWhitespace $ DifferentLine (n - 1) 1
let (afterComms, span2) = finalToList $ enrichComms fixedSpanEnd (reverse dComments)
let (immediate, later) = List.span (\case
MEComment{} -> True
_ -> False
) afterComms
finalYield $ MEDecl withoutComments [ comm | MEComment comm <- immediate ]
later `forM_` finalYield
enrichDecls span2 declRest
EpAnn _anchor _items (EpaCommentsBalanced{}) ->
error "EpaCommentsBalanced"
EpAnnNotUsed -> error "EpAnnNotUsed"
(L (SrcSpanAnn _ann (GHC.UnhelpfulSpan{})) _decl : _declRest) ->
error "UnhelpfulSpan"
-- module head pretty-printing
data ImportLine
= EmptyLines Int
| SamelineComment (Int, EpaCommentTok)
| NewlineComment (Int, EpaCommentTok) -- indentation and comment
| ImportStatement ImportStatementRecord
instance Show ImportLine where
show = \case
EmptyLines n -> "EmptyLines " ++ show n
SamelineComment{} -> "SamelineComment"
NewlineComment{} -> "NewlineComment"
ImportStatement r ->
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
data ImportStatementRecord = ImportStatementRecord
{ commentsBefore :: [(Int, EpaCommentTok)]
, importStatement :: LImportDecl GhcPs
, commentsSameline :: [(Int, EpaCommentTok)]
, commentsAfter :: [(Int, EpaCommentTok)]
}
instance Show ImportStatementRecord where
show r =
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
transformToImportLine
:: ExactPrint.Pos
-> [LImportDecl GhcPs]
-> FinalList ImportLine ExactPrint.Pos
transformToImportLine startPos is =
let
flattenComms
:: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos
flattenComms = \case
[] -> finalPure
(L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do
case ExactPrint.ss2delta lastSpanEnd span of
SameLine i -> do
finalYield $ SamelineComment (i, comm)
DifferentLine l c -> do
finalYield $ EmptyLines (l - 1)
finalYield $ NewlineComment (c - 1, comm)
flattenComms commRest (ExactPrint.ss2posEnd span)
flattenDecls
:: [LImportDecl GhcPs]
-> ExactPrint.Pos
-> FinalList ImportLine ExactPrint.Pos
flattenDecls = \case
[] -> finalPure
(L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest)
-> \lastSpanEnd ->
let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of
EpAnn anch s (EpaComments cs) ->
([], reverse cs, EpAnn anch s (EpaComments []))
EpAnn anch s (EpaCommentsBalanced cs1 cs2) ->
(reverse cs1, reverse cs2, EpAnn anch s (EpaComments []))
EpAnnNotUsed -> ([], [], EpAnnNotUsed)
in
do
span1 <- flattenComms commsBefore lastSpanEnd
let newlines = case ExactPrint.ss2delta span1 declSpan of
SameLine _ -> 0
DifferentLine i _ -> i - 1
finalYield
$ EmptyLines newlines
finalYield $ ImportStatement ImportStatementRecord
{ commentsBefore = []
, importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl
, commentsSameline = []
, commentsAfter = []
}
span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
flattenDecls declRest span2
(L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) ->
error "UnhelpfulSpan"
in
flattenDecls is startPos
data Partial = PartialCommsOnly [(Int, EpaCommentTok)]
| PartialImport ImportStatementRecord
groupifyImportLines :: [ImportLine] -> [ImportLine]
groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
where
go acc [] = case acc of
PartialCommsOnly comms ->
reverse comms `forM_` \comm -> finalYield $ NewlineComment comm
PartialImport partialRecord ->
finalYield $ ImportStatement $ unpartial partialRecord
go acc (line1 : lineR) = do
newAcc <- case acc of
PartialCommsOnly comms -> case line1 of
e@EmptyLines{} -> do
reverse comms `forM_` \comm -> finalYield $ NewlineComment comm
finalYield e
pure $ PartialCommsOnly []
SamelineComment comm -> do
pure $ PartialCommsOnly (comm : comms)
NewlineComment comm -> pure $ PartialCommsOnly (comm : comms)
ImportStatement record ->
pure $ PartialImport $ record { commentsBefore = comms }
PartialImport partialRecord -> case line1 of
e@EmptyLines{} -> do
finalYield $ ImportStatement $ unpartial partialRecord
finalYield e
pure $ PartialCommsOnly []
SamelineComment comm -> do
if (null $ commentsAfter partialRecord)
then pure $ PartialImport partialRecord
{ commentsSameline = comm : commentsSameline partialRecord
}
else pure $ PartialImport partialRecord
{ commentsAfter = comm : commentsAfter partialRecord
}
NewlineComment comm -> pure $ PartialImport $ partialRecord
{ commentsAfter = comm : commentsAfter partialRecord
}
ImportStatement record -> do
let contestedComments = commentsAfter partialRecord
finalYield $ ImportStatement $ unpartial $ partialRecord
{ commentsAfter = []
}
pure $ PartialImport $ record { commentsBefore = contestedComments }
-- comments in between will stay connected to the following decl
go newAcc lineR
unpartial :: ImportStatementRecord -> ImportStatementRecord
unpartial partialRecord = ImportStatementRecord
{ commentsBefore = reverse (commentsBefore partialRecord)
, importStatement = importStatement partialRecord
, commentsSameline = reverse (commentsSameline partialRecord)
, commentsAfter = reverse (commentsAfter partialRecord)
}
sortCommentedImports :: [ImportLine] -> [ImportLine]
sortCommentedImports =
-- TODO92 we don't need this unpackImports, it is implied later in the process
mergeGroups . map (fmap (sortGroups)) . groupify
where
-- unpackImports :: [ImportLine] -> [ImportLine]
-- unpackImports xs = xs >>= \case
-- l@EmptyLines{} -> [l]
-- l@NewlineComment{} -> [l]
-- l@SamelineComment{} -> [l]
-- ImportStatement r ->
-- map NewlineComment (commentsBefore r) ++ [ImportStatement r] ++ map
-- NewlineComment
-- (commentsAfter r)
mergeGroups :: [Either ImportLine [ImportStatementRecord]] -> [ImportLine]
mergeGroups xs = xs >>= \case
Left x -> [x]
Right y -> ImportStatement <$> y
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
sortGroups =
List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement)
groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
groupify cs = go [] cs
where
go [] = \case
(l@EmptyLines{} : rest) -> Left l : go [] rest
(l@NewlineComment{} : rest) -> Left l : go [] rest
(l@SamelineComment{} : rest) -> Left l : go [] rest
(ImportStatement r : rest) -> go [r] rest
[] -> []
go acc = \case
(l@EmptyLines{} : rest) -> Right (reverse acc) : Left l : go [] rest
(l@NewlineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest
(l@SamelineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest
(ImportStatement r : rest) -> go (r : acc) rest
[] -> [Right (reverse acc)]

741
source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs Normal file
View File

@ -0,0 +1,741 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Haskell.Brittany.Internal.S3_ToBriDocTools where
import qualified Control.Monad.Writer.Strict as Writer
import qualified Data.Char as Char
import Data.Data
import qualified Data.Generics as SYB
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import DataTreePrint
import GHC ( EpAnn(EpAnn, EpAnnNotUsed)
, EpAnnComments
( EpaComments
, EpaCommentsBalanced
)
, GenLocated(L)
, LEpaComment
, Located
, LocatedA
, moduleName
, moduleNameString
)
import qualified GHC
import GHC.Data.FastString ( FastString )
import qualified GHC.OldList as List
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import GHC.Types.Name ( getOccString )
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name.Reader ( RdrName(..) )
import qualified GHC.Types.SrcLoc as GHC
import GHC.Utils.Outputable ( Outputable )
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.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint
as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils
as ExactPrint
-- | Use ExactPrint's output for this node; add a newly generated inline comment
-- at insertion position (meant to point out to the user that this node is
-- not handled by brittany yet). Useful when starting implementing new
-- syntactic constructs when children are not handled yet.
briDocByExact
:: (ExactPrint.ExactPrint ast, Data ast)
=> LocatedA ast
-> ToBriDocM BriDocNumbered
briDocByExact ast = do
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 160 customLayouterF ast)
mModify (+ connectedCommentCount ast)
docExt ast True
-- | Use ExactPrint's output for this node.
-- Consider that for multi-line input, the indentation of the code produced
-- by ExactPrint might be different, and even incompatible with the indentation
-- of its surroundings as layouted by brittany. But there are safe uses of
-- this, e.g. for any top-level declarations.
briDocByExactNoComment
:: (ExactPrint.ExactPrint (GenLocated l ast), Data ast, Data l)
=> GenLocated l ast
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 160 customLayouterF ast)
mModify (+ connectedCommentCount ast)
docExt ast False
-- | Use ExactPrint's output for this node, presuming that this output does
-- not contain any newlines. If this property is not met, the semantics
-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
briDocByExactInlineOnly
:: ( ExactPrint.ExactPrint (GHC.XRec GhcPs a)
, Data (GHC.XRec GhcPs a)
, Data a
, Data (GHC.Anno a)
, Outputable (GHC.Anno a)
)
=> String
-> GHC.XRec GhcPs a
-> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 160 customLayouterF ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast
fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let
exactPrintNode t =
allocateNode $ BDFExternal
-- (ExactPrint.Types.mkAnnKey ast)
-- (foldedAnnKeys ast)
False t
let
errorAction = do
mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
mModify (+ connectedCommentCount ast)
case (fallbackMode, Text.lines exactPrinted) of
(ExactPrintFallbackModeNever, _) -> errorAction
(_, [t]) -> exactPrintNode
(Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
(ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
_ -> errorAction
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
lrdrNameToText :: GenLocated l RdrName -> Text
lrdrNameToText (L _ n) = rdrNameToText n
class PrintRdrNameWithAnns l where
printRdrNameWithAnns :: GenLocated l RdrName -> Text
instance PrintRdrNameWithAnns GHC.SrcSpanAnnN where
printRdrNameWithAnns (L (GHC.SrcSpanAnn epAnn _) name) =
case epAnn of
EpAnn _ (GHC.NameAnn GHC.NameParens _ _ _ _) _ -> f "(" name ")"
EpAnn _ (GHC.NameAnn GHC.NameParensHash _ _ _ _) _ -> f "(#" name "#)"
EpAnn _ (GHC.NameAnn GHC.NameBackquotes _ _ _ _) _ -> f "`" name "`"
EpAnn _ (GHC.NameAnn GHC.NameSquare _ _ _ _) _ -> f "[" name "]"
-- TODO92 There are way more possible constructors here
-- see https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC-Parser-Annotation.html#t:NameAnn
EpAnn _ _ _ -> rdrNameToText name
EpAnnNotUsed -> rdrNameToText name
where
f a b c = Text.pack a <> rdrNameToText b <> Text.pack c
lrdrNameToTextAnnGen
:: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
=> (Text -> Text)
-> GenLocated l RdrName
-> m Text
-- TODO this doesn't need to be monadic. I am pretty sure it started of as
-- a pure function, then at some point annotations were inspected
-- (from reader) but now it is pure again.
-- Leaving it as pseudo-monadic is harmless though (I think? Maybe I should
-- check I don't force some mapM/sequence/… garbage at common callsides
-- for this).
lrdrNameToTextAnnGen f ast = pure $ f $ printRdrNameWithAnns ast
lrdrNameToTextAnn
:: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
=> GenLocated l RdrName
-> m Text
lrdrNameToTextAnn = lrdrNameToTextAnnGen id
lrdrNameToTextAnnTypeEqualityIsSpecial
:: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
=> GenLocated l RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let
f x = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
lrdrNameToTextAnnGen f ast
-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
-- the annotations for a (parent) node for a tick to be added to the
-- literal.
-- Excessively long name to reflect on us having to work around such
-- excessively obscure special cases in the exactprint API.
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
:: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
=> Located ast
-> GenLocated l RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick _ast1 ast2 = do
-- TODO92
-- hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2
let
lit = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
return lit -- $ if hasQuote then Text.cons '\'' lit else lit
askIndent :: (MonadMultiReader Config m) => m Int
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
-- TODO92 this is not filtering enough yet, see old code below
hasAnyCommentsBelow :: Data ast => ast -> Bool
hasAnyCommentsBelow =
getAny . SYB.everything (<>) (SYB.mkQ (Any False) (\(_ :: LEpaComment) -> Any True))
-- -- | True if there are any comments that are
-- -- a) connected to any node below (in AST sense) the given node AND
-- -- b) after (in source code order) the node.
-- hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
-- hasAnyCommentsBelow ast@(L l _) =
-- List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
-- <$> astConnectedComments ast
-- extractRestComments
-- :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
-- extractRestComments ann =
-- ExactPrint.annFollowingComments ann
-- ++ (ExactPrint.annsDP ann >>= \case
-- (ExactPrint.AnnComment com, dp) -> [(com, dp)]
-- _ -> []
-- )
-- filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
-- filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
hasCommentsBetween
:: Data ast
=> ast
-> Maybe GHC.RealSrcLoc
-> Maybe GHC.RealSrcLoc
-> Bool
hasCommentsBetween ast left right = do
getAny $ SYB.everything
(<>)
(SYB.mkQ
(Any False)
(\(L (GHC.Anchor pos _) _ :: LEpaComment) -> Any
( (maybe True (GHC.realSrcSpanStart pos >=) left)
&& (maybe True (GHC.realSrcSpanEnd pos <=) right)
)
)
)
ast
-- mAnn <- astAnn ast
-- let
-- go1 [] = False
-- go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
-- go1 (_ : rest) = go1 rest
-- go2 [] = False
-- go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
-- go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
-- go2 (_ : rest) = go2 rest
-- case mAnn of
-- Nothing -> pure False
-- Just ann -> pure $ go1 $ ExactPrint.annsDP ann
-- | True if there are any comments that are connected to any node below (in AST
-- sense) the given node
hasAnyCommentsConnected :: (Data ann, Data ast) => GHC.GenLocated ann ast -> Bool
hasAnyCommentsConnected =
getAny . SYB.everything (<>) (SYB.mkQ (Any False) (\(_ :: LEpaComment) -> Any True))
connectedCommentCount :: (Data ann, Data ast) => GHC.GenLocated ann ast -> CommentCounter
connectedCommentCount =
getSum . SYB.everything (<>) (SYB.mkQ (Sum 0) (\(_ :: LEpaComment) -> Sum 1))
-- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node
-- hasAnyRegularCommentsConnected :: GenLocated ann ast -> Bool
-- hasAnyRegularCommentsConnected ast =
-- any isRegularComment $ astConnectedComments ast
-- | Regular comments are comments that are actually "source code comments",
-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
-- used by ghc-exactprint for capturing symbols (and their exact positioning).
--
-- Only the type instance layouter makes use of this filter currently, but
-- it might make sense to apply it more aggressively or make it the default -
-- I believe that most of the time we branch on the existence of comments, we
-- only care about "regular" comments. We simply did not need the distinction
-- because "irregular" comments are not that common outside of type/data decls.
-- isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
-- isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
astConnectedComments
:: (Data ann, Data ast)
=> GHC.GenLocated ann ast
-> [LEpaComment]
astConnectedComments =
SYB.listify (\(_ :: LEpaComment) -> True)
-- anns <- filterAnns ast <$> mAsk
-- pure $ extractAllComments =<< Map.elems anns
--
-- hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
-- hasAnyCommentsPrior ast = astAnn ast <&> \case
-- Nothing -> False
-- Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
-- hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
-- hasAnyRegularCommentsRest ast = astAnn ast <&> \case
-- Nothing -> False
-- Just ann -> any isRegularComment (extractRestComments ann)
-- hasAnnKeywordComment
-- :: GHC.LocatedA ast -> AnnKeywordId -> Bool
-- hasAnnKeywordComment (L (GHC.SrcSpanAnn ann _) _) annKeyword = False -- _ ann
-- Nothing -> False
-- Just ann -> any hasK (extractAllComments ann)
-- where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
-- new BriDoc stuff
allocateNode
:: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
allocateNode bd = do
i <- allocNodeIndex
return (i, bd)
allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
allocNodeIndex = do
NodeAllocIndex i <- mGet
mSet $ NodeAllocIndex (i + 1)
return i
docEmpty :: ToBriDocM BriDocNumbered
docEmpty = allocateNode BDFEmpty
docLit :: Text -> ToBriDocM BriDocNumbered
docLit t = allocateNode $ BDFLit t
docLitS :: String -> ToBriDocM BriDocNumbered
docLitS s = allocateNode $ BDFLit $ Text.pack s
docExt
:: (ExactPrint.ExactPrint (GenLocated l ast))
=> GenLocated l ast
-> Bool
-> ToBriDocM BriDocNumbered
docExt x shouldAddComment = allocateNode $ BDFExternal
-- (ExactPrint.Types.mkAnnKey x)
-- (foldedAnnKeys x)
shouldAddComment
(Text.pack
$ List.dropWhile ((==) '\n')
$ ExactPrint.exactPrint
$ ExactPrint.makeDeltaAst x
)
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docAlt l = allocateNode . BDFAlt =<< sequence l
newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc = when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action
docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docSeq [] = docEmpty
docSeq l = allocateNode . BDFSeq =<< sequence l
docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docLines l = allocateNode . BDFLines =<< sequence l
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docCols sig l = allocateNode . BDFCols sig =<< sequence l
docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetBaseY bdm = do
bd <- bdm
-- the order here is important so that these two nodes can be treated
-- properly over at `transformAlts`.
n1 <- allocateNode $ BDFBaseYPushCur bd
n2 <- allocateNode $ BDFBaseYPop n1
return n2
docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetIndentLevel bdm = do
bd <- bdm
n1 <- allocateNode $ BDFIndentLevelPushCur bd
n2 <- allocateNode $ BDFIndentLevelPop n1
return n2
docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetBaseAndIndent = docSetBaseY . docSetIndentLevel
docSeparator :: ToBriDocM BriDocNumbered
docSeparator = allocateNode BDFSeparator
docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm
docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm
docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm
docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm
docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docDebug s bdm = allocateNode . BDFDebug s =<< bdm
appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
appSep x = docSeq [x, docSeparator]
docCommaSep :: ToBriDocM BriDocNumbered
docCommaSep = appSep $ docLit $ Text.pack ","
docParenLSep :: ToBriDocM BriDocNumbered
docParenLSep = appSep docParenL
-- TODO: we don't make consistent use of these (yet). However, I think the
-- most readable approach overall might be something else: define
-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.
-- I think those two would make the usage most readable.
-- lit "(" and appSep (lit "(") are understandable and short without
-- introducing a new top-level binding for all types of parentheses.
docParenL :: ToBriDocM BriDocNumbered
docParenL = docLit $ Text.pack "("
docParenR :: ToBriDocM BriDocNumbered
docParenR = docLit $ Text.pack ")"
docParenHashLSep :: ToBriDocM BriDocNumbered
docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
docParenHashRSep :: ToBriDocM BriDocNumbered
docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
docBracketL :: ToBriDocM BriDocNumbered
docBracketL = docLit $ Text.pack "["
docBracketR :: ToBriDocM BriDocNumbered
docBracketR = docLit $ Text.pack "]"
docTick :: ToBriDocM BriDocNumbered
docTick = docLit $ Text.pack "'"
docPar
:: ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docPar lineM indentedM = do
line <- lineM
indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented
docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
docEnsureIndent
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docFlushRemaining fileThing = docFlushCommsPost
(Just $ GHC.mkRealSrcLoc fileThing 999999 999999)
-- CLASS DocHandleComms --------------------------------------------------------
class DocHandleComms ann a where
docHandleComms :: HasCallStack => ann -> a -> a
instance DocHandleComms [LEpaComment] (ToBriDocM BriDocNumbered) where
docHandleComms comms bdm = do
bd <- bdm
i1 <- allocNodeIndex
pure (i1, BDFQueueComments comms bd)
instance DocHandleComms (EpAnn a) (ToBriDocM BriDocNumbered) where
docHandleComms epAnn bdm = case epAnn of
EpAnn anch _ (EpaComments []) -> do
bd <- bdm
i1 <- allocNodeIndex
pure
(i1, BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch) bd)
EpAnn anch _ (EpaComments comms) -> do
bd <- bdm
i1 <- allocNodeIndex
i2 <- allocNodeIndex
pure
( i1
, BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch)
(i2, BDFQueueComments (reverse comms) bd)
)
EpAnn anch _ (EpaCommentsBalanced commsB commsA) -> do
bd <- bdm
i1 <- allocNodeIndex
i2 <- allocNodeIndex
pure
( i1
, BDFQueueComments
(reverse commsB ++ reverse commsA)
( i2
, BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch) bd
)
)
EpAnnNotUsed -> bdm
instance DocHandleComms (GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) where
docHandleComms loc = docHandleComms (GHC.realSrcSpanStart loc)
instance DocHandleComms (GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where
docHandleComms loc bdm = do
bd <- bdm
i1 <- allocNodeIndex
pure (i1, BDFFlushCommentsPrior loc bd)
instance DocHandleComms (Maybe GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) where
docHandleComms Nothing bdm = bdm
docHandleComms (Just loc) bdm = docHandleComms loc bdm
instance DocHandleComms (Maybe GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where
docHandleComms Nothing bdm = bdm
docHandleComms (Just loc) bdm = docHandleComms loc bdm
instance DocHandleComms (GHC.SrcLoc) (ToBriDocM BriDocNumbered) where
docHandleComms (GHC.RealSrcLoc loc _) bdm = docHandleComms loc bdm
docHandleComms (GHC.UnhelpfulLoc _) bdm = bdm
instance DocHandleComms (GHC.LocatedA ast) (ToBriDocM BriDocNumbered) where
docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
GHC.UnhelpfulSpan _ -> bdm
instance DocHandleComms (GHC.LocatedL ast) (ToBriDocM BriDocNumbered) where
docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
GHC.UnhelpfulSpan _ -> bdm
instance DocHandleComms (GHC.LocatedC ast) (ToBriDocM BriDocNumbered) where
docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
GHC.UnhelpfulSpan _ -> bdm
instance DocHandleComms (GHC.LocatedN ast) (ToBriDocM BriDocNumbered) where
docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
GHC.UnhelpfulSpan _ -> bdm
instance DocHandleComms ann (ToBriDocM BriDocNumbered)
=> DocHandleComms ann (ToBriDocM [BriDocNumbered]) where
docHandleComms ann bdm = do
x <- bdm
case x of
[] -> error "docHandleComms empty list"
-- TODO92
-- do
-- el <- docHandleComms ann docEmpty
-- pure [el]
(bd1:bdR) -> do
bd1' <- docHandleComms ann (pure bd1)
pure (bd1':bdR)
instance DocHandleComms ann (ToBriDocM BriDocNumbered)
=> DocHandleComms ann (ToBriDocM (Seq BriDocNumbered))
where
docHandleComms ast bdsm = do
bds <- bdsm
case Seq.viewl bds of
Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
bd1 Seq.:< rest -> do
bd1' <- docHandleComms ast (return bd1)
return $ bd1' Seq.<| rest
instance DocHandleComms ann (ToBriDocM BriDocNumbered)
=> DocHandleComms ann [ToBriDocM BriDocNumbered] where
docHandleComms ann bdms = do
case bdms of
[] -> error "docHandleComms empty list"
-- [docHandleComms ann docEmpty]
(bd1:bdR) -> (docHandleComms ann bd1:bdR)
instance DocHandleComms GHC.EpaLocation (ToBriDocM BriDocNumbered) where
docHandleComms loc bdm = docHandleComms (GHC.epaLocationRealSrcSpan loc) bdm
instance DocHandleComms GHC.SrcSpan (ToBriDocM BriDocNumbered) where
docHandleComms (GHC.RealSrcSpan s _) bdm = docHandleComms s bdm
docHandleComms (GHC.UnhelpfulSpan _) bdm = bdm
-- CLASS ObtainAnnPos ----------------------------------------------------------
class ObtainAnnPos key ann where
obtainAnnPos :: ann -> key -> Maybe GHC.RealSrcLoc
instance ObtainAnnPos AnnKeywordId GHC.AddEpAnn where
obtainAnnPos (GHC.AddEpAnn eKW loc) kw = if eKW == kw
then Just (epaLocationRealSrcSpanStart loc)
else Nothing
instance ObtainAnnPos AnnKeywordId (EpAnn GHC.AnnsModule) where
obtainAnnPos = \case
EpAnnNotUsed -> \_kw -> Nothing
EpAnn _ (GHC.AnnsModule l annList) _ -> \kw ->
obtainAnnPos l kw <|> obtainAnnPos annList kw
instance ObtainAnnPos AnnKeywordId (Maybe GHC.AddEpAnn) where
obtainAnnPos Nothing _ = Nothing
obtainAnnPos (Just addEpAnn) kw = obtainAnnPos addEpAnn kw
instance ObtainAnnPos AnnKeywordId [GHC.AddEpAnn] where
obtainAnnPos list kw =
case [ loc | GHC.AddEpAnn eKW loc <- list, eKW == kw ] of
[] -> Nothing
locs -> Just (epaLocationRealSrcSpanStart $ minimum locs)
instance ObtainAnnPos AnnKeywordId (EpAnn [GHC.AddEpAnn]) where
obtainAnnPos EpAnnNotUsed _kw = Nothing
obtainAnnPos (EpAnn _ list _) kw = obtainAnnPos list kw
instance ObtainAnnPos AnnKeywordId (EpAnn GHC.AnnList) where
obtainAnnPos = \case
EpAnnNotUsed -> \_kw -> Nothing
EpAnn _ annList _ -> \kw -> obtainAnnPos annList kw
instance ObtainAnnPos AnnKeywordId GHC.AnnList where
obtainAnnPos (GHC.AnnList _ op cl addEpAnn _) kw =
obtainAnnPos op kw <|> obtainAnnPos cl kw <|> obtainAnnPos addEpAnn kw
instance ObtainAnnPos AnnKeywordId (EpAnn GHC.GrhsAnn) where
obtainAnnPos = \case
EpAnn _ (GHC.GrhsAnn _ addEpAnn) _ -> obtainAnnPos addEpAnn
EpAnnNotUsed -> \_kw -> Nothing
instance ObtainAnnPos AnnKeywordId GHC.SrcSpanAnnL where
obtainAnnPos = \case
GHC.SrcSpanAnn epAnn _ -> obtainAnnPos epAnn
class ObtainAnnPos AnnKeywordId ann => ObtainAnnDeltaPos ann where
obtainAnnDeltaPos :: ann -> AnnKeywordId -> Maybe GHC.DeltaPos
instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where
obtainAnnDeltaPos = \case
EpAnnNotUsed -> \_kw -> Nothing
EpAnn _ (GHC.AnnsModule l annList) epaComms -> \kw -> do
loc <- obtainAnnPos l kw <|> obtainAnnPos annList kw
let pos = (GHC.srcLocLine loc, GHC.srcLocCol loc)
pure $ ExactPrint.pos2delta
(maximum $ (0, 1) :
[ ExactPrint.ss2posEnd $ GHC.anchor anch
| L anch _ <- case epaComms of
EpaCommentsBalanced cs1 cs2 -> cs1 ++ cs2
EpaComments cs -> cs
, let compPos = ExactPrint.ss2posEnd (GHC.anchor anch)
, compPos <= pos
]
)
pos
class DocFlushCommsPost a where
docFlushCommsPost :: Maybe GHC.RealSrcLoc -> a -> a
instance DocFlushCommsPost (ToBriDocM BriDocNumbered) where
docFlushCommsPost = \case
Nothing -> id
Just span -> \bdm -> do
i1 <- allocNodeIndex
bd <- bdm
pure (i1, BDFFlushCommentsPost span bd)
instance DocFlushCommsPost (ToBriDocM [BriDocNumbered]) where
docFlushCommsPost loc bdm = do
bds <- bdm
case bds of
[] -> do
e <- docFlushCommsPost loc docEmpty
pure [e]
_ -> do
e <- docFlushCommsPost loc (pure $ List.last bds)
pure (List.init bds ++ [e])
unknownNodeError
:: (Data a, Data (GHC.Anno a), Outputable (GHC.Anno a))
=> String
-> GHC.XRec GhcPs a
-> ToBriDocM BriDocNumbered
unknownNodeError infoStr ast = do
mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]
spacifyDocs [] = []
spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
shareDoc :: ToBriDocM a -> ToBriDocM (ToBriDocM a)
shareDoc = fmap pure
obtainListElemStartCommaLocs
:: LocatedA ast -> (Maybe GHC.RealSrcLoc, Maybe GHC.RealSrcLoc)
obtainListElemStartCommaLocs = \case
L (GHC.SrcSpanAnn elemEpAnn _) _ -> case elemEpAnn of
EpAnn anch (GHC.AnnListItem [item]) _ ->
( Just $ GHC.realSrcSpanStart $ GHC.anchor anch
-- yes, we want `realSrcSpanStart span2` here, but have it flow
-- to the end of bd. We want any comments _before_ the _start_
-- of the comma to be inserted _after_ the element.
, Just $ GHC.realSrcSpanStart $ case item of
GHC.AddCommaAnn span -> GHC.epaLocationRealSrcSpan span
GHC.AddSemiAnn span -> GHC.epaLocationRealSrcSpan span
GHC.AddVbarAnn span -> GHC.epaLocationRealSrcSpan span
GHC.AddRarrowAnn span -> GHC.epaLocationRealSrcSpan span
GHC.AddRarrowAnnU span -> GHC.epaLocationRealSrcSpan span
GHC.AddLollyAnnU span -> GHC.epaLocationRealSrcSpan span
)
EpAnn anch _ _ -> (Just $ GHC.realSrcSpanStart $ GHC.anchor anch, Nothing)
EpAnnNotUsed -> (Nothing, Nothing)
docHandleListElemComms
:: (LocatedA ast -> ToBriDocM BriDocNumbered)
-> LocatedA ast
-> ToBriDocM BriDocNumbered
docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of
(posStart, posComma) ->
docHandleComms posStart $ docFlushCommsPost posComma $ layouter e
epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc
epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan

316
source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs Normal file
View File

@ -0,0 +1,316 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.S4_WriteBriDoc
( ppBriDoc
)
where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict
as MultiRWSS
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as TextL.Builder
import GHC ( Anchor(Anchor)
, AnchorOperation
( MovedAnchor
, UnchangedAnchor
)
, EpaComment(EpaComment)
, EpaCommentTok
( EpaBlockComment
, EpaDocCommentNamed
, EpaDocCommentNext
, EpaDocCommentPrev
, EpaDocOptions
, EpaDocSection
, EpaEofComment
, EpaLineComment
)
, GenLocated(L)
, LEpaComment
, RealSrcLoc
)
import GHC.Types.SrcLoc ( realSrcSpanEnd )
import qualified GHC.OldList as List
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Transformations.T1_Alt
import Language.Haskell.Brittany.Internal.Transformations.T2_Floating
import Language.Haskell.Brittany.Internal.Transformations.T3_Par
import Language.Haskell.Brittany.Internal.Transformations.T4_Columns
import Language.Haskell.Brittany.Internal.Transformations.T5_Indent
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
import Language.Haskell.Brittany.Internal.WriteBriDoc.Types
import Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
import Language.Haskell.Brittany.Internal.Components.BriDoc
-- import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
ppBriDoc :: BriDocNumbered -> PPMLocal ()
ppBriDoc 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
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_commentCol = Nothing
, _lstate_addSepSpace = Nothing
, _lstate_commentNewlines = 0
}
state' <-
MultiRWSS.withMultiStateS state
$ MultiRWSS.withMultiStateS ([] :: [LEpaComment])
$ do
layoutBriDocM briDoc'
layoutWriteEnsureBlock
case _lstate_curYOrAddNewline state' of
Left{} -> mTell $ TextL.Builder.fromString "\n"
Right{} -> pure ()
pure ()
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case
BDEmpty -> do
return () -- can it be that simple
BDLit t -> do
layoutIndentRestorePostComment
layoutRemoveIndentLevelLinger
layoutWriteAppend t
BDSeq list -> do
list `forM_` layoutBriDocM
-- in this situation, there is nothing to do about cols.
-- i think this one does not happen anymore with the current simplifications.
-- BDCols cSig list | BDPar sameLine lines <- List.last list ->
-- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
BDCols _ list -> do
list `forM_` layoutBriDocM
BDSeparator -> do
layoutAddSepSpace
BDAddBaseY indent bd -> do
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do
layoutBaseYPushCur
layoutBriDocM bd
BDBaseYPop bd -> do
layoutBriDocM bd
layoutBaseYPop
BDIndentLevelPushCur bd -> do
layoutIndentLevelPushCur
layoutBriDocM bd
BDIndentLevelPop bd -> do
layoutBriDocM bd
layoutIndentLevelPop
BDEnsureIndent indent bd -> do
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteEnsureBlock
layoutBriDocM bd
BDPar indent sameLine indented -> do
layoutBriDocM sameLine
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteNewlineBlock
layoutBriDocM indented
BDLines lines -> alignColsLines layoutBriDocM lines
BDAlt [] -> error "empty BDAlt"
BDAlt (alt : _) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDExternal shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
when shouldAddComment $ do
layoutWriteAppend $ Text.pack $ "{- via external! -}"
zip [1 ..] tlines `forM_` \(i, l) -> do
layoutWriteAppend $ l
unless (i == tlineCount) layoutWriteNewlineBlock
BDPlain t -> do
layoutWriteAppend t
-- BDAnnotationPrior comms bd -> do
-- -- state <- mGet
-- -- let m = _lstate_comments state
-- -- let
-- -- moveToExactLocationAction = case _lstate_curYOrAddNewline state of
-- -- Left{} -> pure ()
-- -- Right{} -> moveToExactAnn annKey
-- -- case mAnn of
-- -- Nothing -> moveToExactLocationAction
-- -- Just [] -> moveToExactLocationAction
-- -- Just priors -> do
-- -- -- layoutResetSepSpace
-- -- priors
-- -- `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
-- -- when (comment /= "(" && comment /= ")") $ do
-- -- let commentLines = Text.lines $ Text.pack $ comment
-- -- case comment of
-- -- ('#' : _) ->
-- -- layoutMoveToCommentPos y (-999) (length commentLines)
-- -- -- ^ evil hack for CPP
-- -- _ -> layoutMoveToCommentPos y x (length commentLines)
-- -- -- fixedX <- fixMoveToLineByIsNewline x
-- -- -- replicateM_ fixedX layoutWriteNewline
-- -- -- layoutMoveToIndentCol y
-- -- layoutWriteAppendMultiline commentLines
-- -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
-- -- moveToExactLocationAction
-- printComments comms
-- mModify (\s -> s + CommentCounter (length comms))
-- layoutBriDocM bd
-- BDAnnotationPost comms bd -> do
-- layoutBriDocM bd
-- printComments comms
-- mModify (\s -> s + CommentCounter (length comms))
-- annMay <- do
-- state <- mGet
-- let m = _lstate_comments state
-- pure $ Map.lookup annKey m
-- let mComments = nonEmpty . extractAllComments =<< annMay
-- -- let
-- -- semiCount = length
-- -- [ ()
-- -- | Just ann <- [annMay]
-- -- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
-- -- ]
-- shouldAddSemicolonNewlines <-
-- mAsk
-- <&> _conf_layout
-- .> _lconfig_experimentalSemicolonNewlines
-- .> confUnpack
-- case mComments of
-- Nothing -> do
-- when shouldAddSemicolonNewlines $ do
-- [1 .. semiCount] `forM_` const layoutWriteNewline
-- Just comments -> do
-- comments
-- `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
-- when (comment /= "(" && comment /= ")") $ do
-- let commentLines = Text.lines $ Text.pack comment
-- case comment of
-- ('#' : _) -> layoutMoveToCommentPos y (-999) 1
-- -- ^ evil hack for CPP
-- ")" -> pure ()
-- -- ^ fixes the formatting of parens
-- -- on the lhs of type alias defs
-- _ -> layoutMoveToCommentPos y x (length commentLines)
-- -- fixedX <- fixMoveToLineByIsNewline x
-- -- replicateM_ fixedX layoutWriteNewline
-- -- layoutMoveToIndentCol y
-- layoutWriteAppendMultiline commentLines
-- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDQueueComments comms bd -> do
existing :: [GHC.LEpaComment] <- mGet
mSet $ mergeOn (\(L l _) -> l) existing comms
layoutBriDocM bd
BDFlushCommentsPrior loc bd -> do
comms <- takeBefore loc
printComments comms
mModify (\s -> s + CommentCounter (length comms))
layoutBriDocM bd
BDFlushCommentsPost loc bd -> do
layoutBriDocM bd
comms <- takeBefore loc
mModify (\s -> s + CommentCounter (length comms))
printComments comms
BDNonBottomSpacing _ bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd
BDDebug s bd -> do
mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd
mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn _f xs [] = xs
mergeOn _f [] ys = ys
mergeOn f xs@(x:xr) ys@(y:yr)
| f x <= f y = x : mergeOn f xr ys
| otherwise = y : mergeOn f xs yr
takeBefore
:: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment]
takeBefore loc = do
comms <- mGet
let (before, after) = List.span
(\(L (Anchor spanC _) _) -> realSrcSpanEnd spanC <= loc)
comms
mSet after
pure before
printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m ()
printComments comms = do
let
addComment s anchor prior = do
case anchor of
Anchor span UnchangedAnchor ->
moveToCommentPos True $ ExactPrint.ss2deltaEnd prior span
Anchor _span (MovedAnchor dp) -> moveToCommentPos False dp
-- ppmMoveToExactLoc $ ExactPrint.ss2deltaEnd prior span
layoutWriteAppend $ Text.pack s
comms `forM_` \case
L anch (EpaComment (EpaDocCommentNext s) prior) -> addComment s anch prior
L anch (EpaComment (EpaDocCommentPrev s) prior) -> addComment s anch prior
L anch (EpaComment (EpaDocCommentNamed s) prior) -> addComment s anch prior
L anch (EpaComment (EpaDocSection _ s) prior) -> addComment s anch prior
L anch (EpaComment (EpaDocOptions s) prior) -> addComment s anch prior
L anch (EpaComment (EpaLineComment s) prior) -> addComment s anch prior
L anch (EpaComment (EpaBlockComment s) prior) -> addComment s anch prior
L _anch (EpaComment (EpaEofComment) _prior) -> pure ()

256
source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs Normal file
View File

@ -0,0 +1,256 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.StepOrchestrate
( processModule
)
where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict
as MultiRWSS
import Data.CZipWith
import qualified Data.Map.Strict as Map
-- import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.Builder as TextL.Builder
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC
import GHC ( EpaCommentTok
( EpaBlockComment
, EpaEofComment
, EpaLineComment
)
, GenLocated(L)
, HsModule(HsModule)
, LHsDecl
, SrcSpanAnn'(SrcSpanAnn)
)
import qualified GHC.OldList as List
import GHC.Types.SrcLoc ( srcSpanFileName_maybe )
import qualified Language.Haskell.GHC.ExactPrint
as ExactPrint
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
( splitModule )
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.S4_WriteBriDoc
( ppBriDoc )
import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
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
-- 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.
processModule
:: TraceFunc
-> Config
-> PerItemConfig
-> GHC.ParsedSource
-> IO ([BrittanyError], TextL.Text)
processModule traceFunc conf inlineConf parsedModule = do
let shouldReformatHead =
conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack @Bool
let
wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf
. MultiRWSS.withMultiState_ (CommentCounter 0)
FinalList moduleElementsStream = splitModule
shouldReformatHead
parsedModule
(obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere)
((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiReader traceFunc
$ moduleElementsStream
(\modElem cont -> do
case modElem of
MEExactModuleHead modHead -> wrapNonDeclToBriDoc $ do
bdMay <- ppModuleHead modHead
case bdMay of
Nothing -> pure ()
Just bd -> ppBriDoc bd
MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do
case modHead of
HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do
(bd, _) <-
briDocMToPPM
$ maybe id
docFlushRemaining
(srcSpanFileName_maybe loc)
$ docHandleComms epAnn docSeparator
ppBriDoc bd
HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error
"brittany internal error: exports without module name"
HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do
let startDelta = obtainAnnDeltaPos epAnn GHC.AnnModule
tellDebugMess (show startDelta)
case startDelta of
Nothing -> pure ()
Just GHC.SameLine{} -> pure ()
Just (GHC.DifferentLine r _) ->
mTell $ TextL.Builder.fromString $ replicate (r - 1) '\n'
(bd, _) <-
briDocMToPPM
$ maybe id
docFlushRemaining
(srcSpanFileName_maybe loc)
$ moduleNameExportBridoc epAnn n les
ppBriDoc bd
MEImportDecl importDecl immediateAfterComms ->
wrapNonDeclToBriDoc $ do
(bd, _) <-
briDocMToPPM
$ docSeq
( layoutImport importDecl
: map commentToDoc immediateAfterComms
)
ppBriDoc bd
MEDecl decl immediateAfterComms -> do
let declConfig = getDeclConfig conf inlineConf decl
MultiRWSS.withMultiReader declConfig
$ MultiRWSS.withMultiState_ (CommentCounter 0)
$ ppToplevelDecl decl immediateAfterComms
MEComment (ind, EpaLineComment str) -> do
mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
mTell $ TextL.Builder.fromString "\n"
MEComment (ind, EpaBlockComment str) -> do
mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
mTell $ TextL.Builder.fromString "\n"
MEComment (_, EpaEofComment) -> pure ()
MEComment _ ->
mTell $ TextL.Builder.fromString "some other comment"
MEWhitespace dp -> do
-- mTell $ TextL.Builder.fromString "B"
-- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp)
ppmMoveToExactLoc dp
cont
)
(\x -> do
-- mTell $ TextL.Builder.fromString "\n"
pure x
)
-- _tracer =
-- -- if Seq.null debugStrings
-- -- then id
-- -- else
-- trace ("---- DEBUGMESSAGES ---- ")
-- . foldr (seq . join trace) id debugStrings
debugStrings `forM_` \s -> useTraceFunc traceFunc s
moduleElementsStream
(\el rest -> do
case el of
MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead"
MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead"
MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl"
MEDecl{} -> useTraceFunc traceFunc "MEDecl"
MEComment{} -> useTraceFunc traceFunc "MEComment"
MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
rest
)
(\_ -> pure ())
pure (errs, TextL.Builder.toLazyText out)
commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
commentToDoc (indent, c) = case c of
GHC.EpaDocCommentNext str -> docLitS (replicate indent ' ' ++ str)
GHC.EpaDocCommentPrev str -> docLitS (replicate indent ' ' ++ str)
GHC.EpaDocCommentNamed str -> docLitS (replicate indent ' ' ++ str)
GHC.EpaDocSection _ str -> docLitS (replicate indent ' ' ++ str)
GHC.EpaDocOptions str -> docLitS (replicate indent ' ' ++ str)
GHC.EpaLineComment str -> docLitS (replicate indent ' ' ++ str)
GHC.EpaBlockComment str -> docLitS (replicate indent ' ' ++ str)
GHC.EpaEofComment -> docEmpty
-- Prints the information associated with the module annotation
-- This includes the imports
-- This returns a `Maybe` because it only produces a BriDocNumbered if
-- re-formatting the module head is enabled. We maybe should change that
-- for consistency.
ppModuleHead :: GHC.ParsedSource -> PPMLocal (Maybe BriDocNumbered)
ppModuleHead lmod = do
processDefault lmod $> Nothing
processDefault
:: (ExactPrint.ExactPrint ast, MonadMultiWriter Text.Builder.Builder m)
-- , MonadMultiReader ExactPrint.Types.Anns m
=> GHC.Located ast
-> m ()
processDefault x = do
let str = ExactPrint.exactPrint x
-- this hack is here so our print-empty-module trick does not add
-- a newline at the start if there actually is no module header / imports
-- / anything.
-- TODO: instead the appropriate annotation could be removed when "cleaning"
-- the module (header). This would remove the need for this hack!
case str of
"\n" -> return ()
_ -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str
getDeclConfig
:: Config
-> PerItemConfig
-> GHC.LHsDecl GhcPs
-> Config
getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
where
declBindingNames = getDeclBindingNames decl
mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
mDeclConf = case GHC.locA $ GHC.getLoc decl of
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 @Bool
bd <- fmap fst $ if exactprintOnly
then briDocMToPPM
$ docSeq (briDocByExact 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
$ docSeq (innerDoc : map commentToDoc immediateAfterComms)
if errorCount == 0 then pure (r, 0) else briDocMToPPM $ briDocByExact decl
ppBriDoc bd
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
-- ++ ")!"

292
source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs → source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs
View File

@ -1,81 +1,92 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.DataDecl where
module Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl where
import qualified Data.Data
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (GenLocated(L), Located)
import qualified GHC
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.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.ToBriDoc.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
layoutDataDecl
:: Located (TyClDecl GhcPs)
-> Located RdrName
:: LTyClDecl GhcPs
-> LIdP GhcPs
-> LHsQTyVars GhcPs
-> [LHsTypeArg GhcPs]
-> HsDataDefn GhcPs
-> ToBriDocM BriDocNumbered
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
layoutDataDecl ltycl name (HsQTvs _ bndrs) pats defn = case defn of
-- newtype MyType a b = MyType ..
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
HsDataDefn NoExtField NewType Nothing _ctype Nothing [cons] mDerivs ->
case cons of
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
-> docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs
-- headDoc <- fmap return $ docSeq
-- [ appSep $ docLitS "newtype")
-- , appSep $ docLit nameStr
-- , appSep tyVarLine
-- ]
rhsDoc <- return <$> createDetailsDoc consNameStr details
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "newtype"
, appSep $ docLit nameStr
, appSep tyVarLine
, docSeparator
, docLitS "="
, docSeparator
, rhsDoc
]
(L _ (ConDeclH98 epAnn consName False _qvars ctxMay details _conDoc)) ->
let isSimple = case ctxMay of
Nothing -> True
Just (L _ []) -> True
_ -> False
in if isSimple
then do
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- shareDoc $ createBndrDoc bndrs
patDocs <- mapM shareDoc $ layoutHsTyPats pats
-- headDoc <- fmap return $ docSeq
-- [ appSep $ docLitS "newtype")
-- , appSep $ docLit nameStr
-- , appSep tyVarLine
-- ]
rhsDoc <- return <$> createDetailsDoc consNameStr details
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "newtype"
, appSep $ docLit nameStr
, appSep tyVarLine
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
, docSeparator
, docLitS "="
, docSeparator
, docHandleComms epAnn $ rhsDoc
]
else briDocByExactNoComment ltycl
_ -> briDocByExactNoComment ltycl
-- data MyData a b
-- (zero constructors)
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "data"
, lhsContextDoc
, appSep $ docLit nameStr
, appSep tyVarLine
]
HsDataDefn NoExtField DataType ctxMay _ctype Nothing [] mDerivs -> do
lhsContextDoc <- case ctxMay of
Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
Nothing -> pure docEmpty
nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs
patDocs <- mapM shareDoc $ layoutHsTyPats pats
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "data"
, lhsContextDoc
, appSep $ docLit nameStr
, appSep tyVarLine
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
]
-- data MyData = MyData ..
-- data MyData = MyData { .. }
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
HsDataDefn NoExtField DataType ctxMay _ctype Nothing [cons] mDerivs ->
case cons of
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
-> docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
(L _ (ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc))
-> do
lhsContextDoc <- case ctxMay of
Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
Nothing -> pure docEmpty
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs
patDocs <- mapM shareDoc $ layoutHsTyPats pats
forallDocMay <- case createForallDoc qvars of
Nothing -> pure Nothing
Just x -> Just . pure <$> x
@ -83,8 +94,11 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
Nothing -> pure Nothing
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
rhsDoc <- return <$> createDetailsDoc consNameStr details
let posEqual = obtainAnnPos epAnn AnnEqual
consDoc <-
fmap pure
shareDoc
$ docHandleComms epAnn
$ docHandleComms posEqual
$ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of
(Just forallDoc, Just rhsContextDoc) -> docLines
@ -111,14 +125,15 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
createDerivingPar mDerivs $ docAlt
[ -- data D = forall a . Show a => D a
docSeq
[ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
[ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $
docSeq
[ appSep $ docLitS "data"
, docForceSingleline $ lhsContextDoc
, appSep $ docLit nameStr
, appSep tyVarLine
, docSeparator
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
]
, docLitS "="
, docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
, docSeparator
, docSetIndentLevel $ docSeq
[ case forallDocMay of
@ -137,15 +152,17 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, -- data D
-- = forall a . Show a => D a
docAddBaseY BrIndentRegular $ docPar
(docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
docSeq
[ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc
, appSep $ docLit nameStr
, tyVarLine
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
]
)
(docSeq
[ docLitS "="
[ docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
, docSeparator
, docSetIndentLevel $ docSeq
[ case forallDocMay of
@ -167,11 +184,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- . Show a =>
-- D a
docAddBaseY BrIndentRegular $ docPar
(docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
docSeq
[ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc
, appSep $ docLit nameStr
, tyVarLine
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
]
)
consDoc
@ -190,8 +209,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
(docLitS "data")
(docLines
[ lhsContextDoc
, docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq [appSep $ docLit nameStr, tyVarLine]
, -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
docSeq [appSep $ docLit nameStr, tyVarLine, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]]
, consDoc
]
)
@ -200,13 +219,23 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
_ -> briDocByExactNoComment ltycl
layoutHsTyPats
:: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = pats <&> \case
HsValArg tm -> layoutType tm
HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]
-- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change
-- is a bit strange. Hopefully this does not ignore any important
-- annotations.
HsArgPar _l -> error "brittany internal error: HsArgPar{}"
createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
createContextDoc [] = docEmpty
createContextDoc [t] =
docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
createContextDoc (t1 : tR) = do
t1Doc <- docSharedWrapper layoutType t1
tRDocs <- tR `forM` docSharedWrapper layoutType
t1Doc <- shareDoc $ layoutType t1
tRDocs <- tR `forM` (shareDoc . layoutType)
docAlt
[ docSeq
[ docLitS "("
@ -228,7 +257,7 @@ createBndrDoc bs = do
tyVarDocs <- bs `forM` \case
(L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
(L _ (KindedTyVar _ _ext lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
d <- shareDoc $ layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
case mKind of
@ -247,57 +276,73 @@ createDerivingPar
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
createDerivingPar derivs mainDoc = do
case derivs of
(L _ []) -> mainDoc
(L _ types) ->
[] -> mainDoc
types ->
docPar mainDoc
$ docEnsureIndent BrIndentRegular
$ docLines
$ docWrapNode derivs
-- TODO92 $ docWrapNode derivs
$ derivingClauseDoc
<$> types
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
(L _ []) -> docSeq []
(L _ ts) ->
let
tsLength = length ts
whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
(lhsStrategy, rhsStrategy) =
maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
in docSeq
[ docDeriving
, docWrapNodePrior types $ lhsStrategy
, docSeparator
, whenMoreThan1Type "("
, docWrapNodeRest types
$ docSeq
$ List.intersperse docCommaSep
$ ts
<&> \case
HsIB _ t -> layoutType t
, whenMoreThan1Type ")"
, rhsStrategy
]
derivingClauseDoc (L _ (HsDerivingClause epAnn mStrategy types)) =
case types of
L _ (DctSingle _ ty) ->
let
(lhsStrategy, rhsStrategy) =
maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
in docSeq
[ docDeriving
, docHandleComms types $ lhsStrategy
, docSeparator
, docHandleListElemComms layoutSigType ty -- TODO92 `docHandleRemaining types` here ?
-- \case
-- HsIB _ t -> layoutType t
, rhsStrategy
]
(L (SrcSpanAnn _multiEpAnn _) (DctMulti NoExtField [])) -> docSeq []
(L (SrcSpanAnn multiEpAnn _) (DctMulti NoExtField ts)) ->
let
tsLength = length ts
whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
(lhsStrategy, rhsStrategy) =
maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
posClose = case multiEpAnn of
EpAnn _ (AnnContext _ _ [s]) _ -> Just $ epaLocationRealSrcSpanStart s
_ -> Nothing
in docSeq
[ docDeriving
, docHandleComms types $ lhsStrategy
, docSeparator
, whenMoreThan1Type "("
, docSeq -- TODO92 `docHandleRemaining types` here ?
$ List.intersperse docCommaSep
$ ts <&> docHandleListElemComms layoutSigType
, docHandleComms posClose $ whenMoreThan1Type ")"
, rhsStrategy
]
where
posDeriving = obtainAnnPos epAnn AnnDeriving
docDeriving = docHandleComms epAnn $ docHandleComms posDeriving $ docLitS "deriving"
strategyLeftRight = \case
(L _ StockStrategy) -> (docLitS " stock", docEmpty)
(L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)
(L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)
lVia@(L _ (ViaStrategy viaTypes)) ->
(L _ (StockStrategy _)) -> (docLitS " stock", docEmpty)
(L _ (AnyclassStrategy _)) -> (docLitS " anyclass", docEmpty)
(L _ (NewtypeStrategy _)) -> (docLitS " newtype", docEmpty)
_lVia@(L _ (ViaStrategy (XViaStrategyPs viaEpAnn viaType))) ->
( docEmpty
, case viaTypes of
HsIB _ext t ->
docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
, docSeq
[ docHandleComms viaEpAnn $ docLitS " via"
, docSeparator
, docHandleListElemComms layoutSigType viaType
]
)
docDeriving :: ToBriDocM BriDocNumbered
docDeriving = docLitS "deriving"
createDetailsDoc
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
:: Text -> HsConDeclH98Details GhcPs -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of
PrefixCon args -> do
PrefixCon _ args -> do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let
singleLine = docSeq
@ -331,8 +376,12 @@ createDetailsDoc consNameStr details = case details of
docAlt [singleLine, multiAppended, multiIndented, leftIndented]
RecCon (L _ []) ->
docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
RecCon lRec@(L _ fields@(_ : _)) -> do
let ((fName1, fType1) : fDocR) = mkFieldDocs fields
RecCon (L (SrcSpanAnn epAnn _) fields@(_ : _)) -> do
let posOpen = obtainAnnPos epAnn AnnOpenC
let posClose = obtainAnnPos epAnn AnnCloseC
let ((fName1, fType1), fDocR) = case mkFieldDocs fields of
(doc1:docR) -> (doc1, docR)
_ -> error "cannot happen (TM)"
-- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
let allowSingleline = False
docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
@ -340,10 +389,10 @@ createDetailsDoc consNameStr details = case details of
addAlternativeCond allowSingleline $ docSeq
[ docLit consNameStr
, docSeparator
, docWrapNodePrior lRec $ docLitS "{"
, docHandleComms posOpen $ docLitS "{"
, docSeparator
, docWrapNodeRest lRec
$ docForceSingleline
, docForceSingleline
$ docHandleComms epAnn
$ docSeq
$ join
$ [fName1, docSeparator, docLitS "::", docSeparator, fType1]
@ -358,28 +407,28 @@ createDetailsDoc consNameStr details = case details of
| (fName, fType) <- fDocR
]
, docSeparator
, docLitS "}"
, docHandleComms posClose $ docLitS "}"
]
addAlternative $ docPar
(docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
(docNonBottomSpacingS $ docLines
[ docAlt
[ docCols
ColRecDecl
[ appSep (docLitS "{")
, appSep $ docForceSingleline fName1
[ docHandleComms posOpen $ appSep (docLitS "{")
, docHandleComms epAnn $ appSep $ docForceSingleline fName1
, docSeq [docLitS "::", docSeparator]
, docForceSingleline $ fType1
]
, docSeq
[ docLitS "{"
[ docHandleComms posOpen $ docLitS "{"
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1
(docSeq [docLitS "::", docSeparator, fType1])
]
]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
, docLines $ fDocR <&> \(fName, fType) ->
docAlt
[ docCols
ColRecDecl
@ -396,7 +445,7 @@ createDetailsDoc consNameStr details = case details of
(docSeq [docLitS "::", docSeparator, fType])
]
]
, docLitS "}"
, docHandleComms posClose $ docLitS "}"
]
)
InfixCon arg1 arg2 -> docSeq
@ -410,8 +459,7 @@ createDetailsDoc consNameStr details = case details of
mkFieldDocs
:: [LConDeclField GhcPs]
-> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
mkFieldDocs = fmap $ \lField -> case lField of
L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
mkFieldDocs = map createNamesAndTypeDoc
createForallDoc
:: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
@ -420,15 +468,19 @@ createForallDoc lhsTyVarBndrs =
Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createNamesAndTypeDoc
:: Data.Data.Data ast
=> Located ast
-> [GenLocated t (FieldOcc GhcPs)]
-> Located (HsType GhcPs)
:: LConDeclField GhcPs
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
[ docSeq $ List.intersperse docCommaSep $ names <&> \case
L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName
]
, docWrapNodeRest lField $ layoutType t
createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) =
( docFlushCommsPost posColon
$ docHandleComms posStart
$ docHandleComms epAnn
$ docSeq
[ docSeq $ List.intersperse docCommaSep $ names <&> \case
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
]
, docFlushCommsPost posComma (layoutType t)
)
where
(posStart, posComma) = obtainListElemStartCommaLocs lField
posColon = obtainAnnPos epAnn AnnDcolon

815
source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs → source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs
View File

File diff suppressed because it is too large Load Diff

1222
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs Normal file
View File

File diff suppressed because it is too large Load Diff

5
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot → source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs-boot
View File

@ -1,16 +1,15 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.Expr where
module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
layoutExpr :: ToBriDoc HsExpr
-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
litBriDoc :: HsLit GhcPs -> BriDocFInt
overLitValBriDoc :: OverLitVal -> BriDocFInt

252
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs Normal file
View File

@ -0,0 +1,252 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.ToBriDoc.IE where
import qualified Data.List.Extra
import qualified Data.Text as Text
import GHC ( GenLocated(L)
, ModuleName
, moduleNameString
, unLoc
)
import GHC.Hs
import qualified GHC.OldList as List
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.Types
import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> LocatedN name
prepareName = ieLWrappedName
layoutIE :: Data.Data.Data ast => ast -> ToBriDoc IE
layoutIE commAst lie@(L _ ie) = docHandleComms lie $ case ie of
IEVar _ x -> layoutWrapped lie x
IEThingAbs _ x -> layoutWrapped lie x
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith epAnn x (IEWildcard _) _ -> do
let posOpen = obtainAnnPos epAnn AnnOpenP
let posClose = obtainAnnPos epAnn AnnCloseP
let posDotDot = obtainAnnPos epAnn AnnDotdot
docSeq
[ layoutWrapped lie x
, docHandleComms posOpen $ docLitS "("
, docHandleComms posDotDot $ docLitS ".."
, docHandleComms posClose $ docLitS ")"
]
IEThingWith epAnn x _ ns -> do
let hasComments = or
( hasCommentsBetween commAst posOpen posClose
: hasAnyCommentsBelow x
: map hasAnyCommentsBelow ns
)
let sortedNs = List.sortOn wrappedNameToText ns
runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
$ [layoutWrapped lie x, docHandleComms posOpen $ docLit $ Text.pack "("]
++ intersperse docCommaSep (map nameDoc sortedNs)
++ [docHandleComms posClose docParenR]
addAlternative
-- $ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular
$ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
where
posOpen = obtainAnnPos epAnn AnnOpenP
posClose = obtainAnnPos epAnn AnnCloseP
nameDoc = docHandleListElemComms (docLit <=< lrdrNameToTextAnn . prepareName)
layoutItem n = docSeq
[ docCommaSep
, -- TODO92 docWrapNode n $
nameDoc n
]
layoutItems FirstLastEmpty = docSetBaseY $ docLines
[ docSeq
[ docHandleComms posOpen docParenLSep
, -- TODO92 docNodeAnnKW lie (Just AnnOpenP)
docEmpty
]
, docHandleComms posClose docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[ docSeq
[ docHandleComms posOpen docParenLSep
, -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $
nameDoc n
]
, docHandleComms posClose docParenR
]
layoutItems (FirstLast n1 nMs nN) =
docSetBaseY
$ docLines
$ [ docSeq
[ docHandleComms posOpen docParenLSep
, -- TODO92 docWrapNode n1 $
nameDoc n1
]
]
++ map layoutItem nMs
++ [ docSeq
[ docCommaSep
, -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $
nameDoc nN
]
, docHandleComms posClose docParenR
]
IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module"
, docSeparator
, docLit . Text.pack . moduleNameString $ unLoc n
]
_ -> docEmpty
where
layoutWrapped _ = \case
L _ (IEName n ) -> docLit =<< lrdrNameToTextAnn n
L _ (IEPattern loc n) -> do
name <- lrdrNameToTextAnn n
docHandleComms loc $ docLit $ Text.pack "pattern " <> name
L _ (IEType loc n) -> do
name <- lrdrNameToTextAnn n
docHandleComms loc $ docLit $ Text.pack "type " <> name
data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- Helper function to deal with Located lists of LIEs.
-- In particular this will also associate documentation
-- from the located list that actually belongs to the last IE.
-- It also adds docCommaSep to all but the first element
-- This configuration allows both vertical and horizontal
-- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
:: (Data.Data.Data a, HasCallStack)
=> SortItemsFlag
-> a
-> [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort commAst lies = do
let makeIENode ie = docSeq [docCommaSep, ie]
let sortedLies =
[ items
| group <- Data.List.Extra.groupOn lieToText
$ List.sortOn lieToText lies
, items <- mergeGroup group
]
let ieDocs = fmap (docHandleListElemComms (layoutIE commAst)) $ case shouldSort of
ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies
ieCommaDocs <- sequence $ case splitFirstLast ieDocs of
FirstLastEmpty -> []
FirstLastSingleton ie -> [ie]
FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
pure $ fmap pure ieCommaDocs -- returned shared nodes
where
mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
mergeGroup [] = []
mergeGroup items@[_] = items
mergeGroup items = if
| all isProperIEThing items -> [List.foldl1' thingFolder items]
| all isIEVar items -> [List.foldl1' thingFolder items]
| otherwise -> items
-- proper means that if it is a ThingWith, it does not contain a wildcard
-- (because I don't know what a wildcard means if it is not already a
-- IEThingAll).
isProperIEThing :: LIE GhcPs -> Bool
isProperIEThing = \case
L _ (IEThingAbs _ _wn) -> True
L _ (IEThingAll _ _wn) -> True
L _ (IEThingWith _ _wn NoIEWildcard _) -> True
_ -> False
isIEVar :: LIE GhcPs -> Bool
isIEVar = \case
L _ IEVar{} -> True
_ -> False
thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
thingFolder l1@(L _ IEVar{} ) _ = l1
thingFolder l1@(L _ IEThingAll{}) _ = l1
thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 ( L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2
thingFolder (L l (IEThingWith x wn _ items1)) (L _ (IEThingWith _ _ _ items2))
= L l (IEThingWith x wn NoIEWildcard (items1 ++ items2))
thingFolder _ _ =
error "thingFolder should be exhaustive because we have a guard above"
-- Builds a complete layout for the given located
-- list of LIEs. The layout provides two alternatives:
-- (item, item, ..., item)
-- ( item
-- , item
-- ...
-- , item
-- )
-- If the llies contains comments the list will
-- always expand over multiple lines, even when empty:
-- () -- no comments
-- ( -- a comment
-- )
layoutLLIEs
:: HasCallStack
=> Bool
-> SortItemsFlag
-> LocatedL [LIE GhcPs]
-> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies@(L epAnn lies) = do
let posOpen = obtainAnnPos epAnn AnnOpenP
let posClose = obtainAnnPos epAnn AnnCloseP
ieDs <- layoutAnnAndSepLLIEs shouldSort llies lies
let hasComments = hasAnyCommentsBelow llies
docOpen <- shareDoc $ docHandleComms posOpen docParenL
docClose <- shareDoc $ docHandleComms posClose docParenR
docHandleComms llies $ runFilteredAlternative $ case ieDs of
[] -> do
addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
addAlternativeCond hasComments $ docPar docOpen docClose
(ieDsH : ieDsT) -> do
addAlternativeCond (not hasComments && enableSingleline)
$ docSeq
$ [docOpen]
++ (docForceSingleline <$> ieDs)
++ [docClose]
addAlternative
$ docPar (docSetBaseY $ docSeq [docOpen, docSeparator, ieDsH])
$ docLines
$ ieDsT
++ [docClose]
-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code.
wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case
L _ (IEName n ) -> lrdrNameToText n
L _ (IEPattern _loc n) -> lrdrNameToText n
L _ (IEType _loc n) -> lrdrNameToText n
-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code.
lieToText :: LIE GhcPs -> Text
lieToText = \case
L _ (IEVar _ wn ) -> wrappedNameToText wn
L _ (IEThingAbs _ wn ) -> wrappedNameToText wn
L _ (IEThingAll _ wn ) -> wrappedNameToText wn
L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some
-- other clever thing.
L _ (IEModuleContents _ n) -> moduleNameToText n
L _ IEGroup{} -> Text.pack "@IEGroup"
L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where
moduleNameToText :: LocatedA ModuleName -> Text
moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)

50
source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs → source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Import.hs
View File

@ -1,19 +1,23 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.Import where
-- TODO92
{-# OPTIONS_GHC -Wno-unused-imports #-}
module Language.Haskell.Brittany.Internal.ToBriDoc.Import where
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (GenLocated(L), Located, moduleNameString, unLoc)
import GHC.Hs
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.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.ToBriDoc.IE
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
@ -23,11 +27,11 @@ prepPkg rawN = case rawN of
-- This would be odd to encounter and the
-- result will most certainly be wrong
NoSourceText -> ""
prepModName :: Located e -> e
prepModName :: LocatedA e -> e
prepModName = unLoc
layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
layoutImport importD = case importD of
layoutImport :: LImportDecl GhcPs -> ToBriDocM BriDocNumbered
layoutImport ldecl@(L _ importD) = docHandleComms ldecl $ case importD of
ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do
importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack
importAsCol <-
@ -75,8 +79,12 @@ layoutImport importD = case importD of
importHead = docSeq [importQualifiers, modNameD]
bindingsD = case mllies of
Nothing -> docEmpty
Just (_, llies) -> do
hasComments <- hasAnyCommentsBelow llies
Just (_, llies@(L llEpAnn lies)) -> do
let hasComments = hasAnyCommentsBelow llies
let posOpen = obtainAnnPos llEpAnn AnnOpenP
let posClose = obtainAnnPos llEpAnn AnnCloseP
docOpen <- shareDoc $ docHandleComms posOpen $ docParenLSep
docClose <- shareDoc $ docHandleComms posClose $ docParenR
if compact
then docAlt
[ docSeq
@ -90,48 +98,48 @@ layoutImport importD = case importD of
in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)
]
else do
ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies
docWrapNodeRest llies
$ docEnsureIndent (BrIndentSpecial hidDocCol)
ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies lies
-- TODO92 docWrapNodeRest llies
docHandleComms llies $ docEnsureIndent (BrIndentSpecial hidDocCol)
$ case ieDs of
-- ..[hiding].( )
[] -> if hasComments
then docPar
(docSeq
[hidDoc, docParenLSep, docWrapNode llies docEmpty]
[hidDoc, docOpen, docEmpty]
)
(docEnsureIndent
(BrIndentSpecial hidDocColDiff)
docParenR
docClose
)
else docSeq
[hidDoc, docParenLSep, docSeparator, docParenR]
[hidDoc, docOpen, docSeparator, docClose]
-- ..[hiding].( b )
[ieD] -> runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
[ hidDoc
, docParenLSep
, docOpen
, docForceSingleline ieD
, docSeparator
, docParenR
, docClose
]
addAlternative $ docPar
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
(docSeq [hidDoc, docOpen, docNonBottomSpacing ieD])
(docEnsureIndent
(BrIndentSpecial hidDocColDiff)
docParenR
docClose
)
-- ..[hiding].( b
-- , b'
-- )
(ieD : ieDs') -> docPar
(docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]
(docSeq [hidDoc, docSetBaseY $ docSeq [docOpen, ieD]]
)
(docEnsureIndent (BrIndentSpecial hidDocColDiff)
$ docLines
$ ieDs'
++ [docParenR]
++ [docClose]
)
makeAsDoc asT =
docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT]

60
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.ToBriDoc.Module where
import qualified Data.Maybe
import qualified Data.Text as Text
import GHC ( ModuleName
, moduleNameString
, unLoc
)
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.ToBriDoc.IE
import Language.Haskell.Brittany.Internal.Types
moduleNameExportBridoc
:: EpAnn AnnsModule
-> LocatedA ModuleName
-> Maybe (LocatedL [LIE GhcPs])
-> ToBriDocM BriDocNumbered
moduleNameExportBridoc epAnn modName les = do
let posModule = obtainAnnPos epAnn AnnModule
let posWhere = obtainAnnPos epAnn AnnWhere
allowSingleLineExportList <-
mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
-- the config should not prevent single-line layout when there is no
-- export list
let tn = Text.pack $ moduleNameString $ unLoc modName
docHandleComms epAnn $ docHandleComms posModule $ runFilteredAlternative $ do
addAlternativeCond allowSingleLine $ docSeq
[ appSep $ docLit $ Text.pack "module"
, appSep $ docLit tn
, docForceSingleline $ appSep $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs True KeepItemsUnsorted x
, docSeparator
, docHandleComms posWhere $ docLit $ Text.pack "where"
]
addAlternative $ docLines
[ docAddBaseY BrIndentRegular $ docPar
(docSeq
[appSep $ docLit $ Text.pack "module", docLit tn]
)
(docSeq
[ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs False KeepItemsUnsorted x
, docSeparator
, docHandleComms posWhere $ docLit $ Text.pack "where"
]
)
]

39
source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs → source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Layouters.Pattern where
module Language.Haskell.Brittany.Internal.ToBriDoc.Pattern where
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
@ -10,12 +10,12 @@ import GHC (GenLocated(L), ol_val)
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.LayouterBasics
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr
import Language.Haskell.Brittany.Internal.ToBriDoc.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
@ -30,7 +30,7 @@ import Language.Haskell.Brittany.Internal.Types
-- We will use `case .. of` as the imagined prefix to the examples used in
-- the different cases below.
layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr
VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
@ -57,7 +57,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- x1' <- docSeq [docLit $ Text.pack "(", return x1]
-- xN' <- docSeq [return xN, docLit $ Text.pack ")"]
-- return $ (x1' Seq.<| middle) Seq.|> xN'
ConPat _ lname (PrefixCon args) -> do
ConPat _ lname (PrefixCon _tyargs args) -> do -- TODO92 is it safe to ignore tyargs??
-- Abc a b c -> expr
nameDoc <- lrdrNameToTextAnn lname
argDocs <- layoutPat `mapM` args
@ -84,11 +84,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutPat fPat
else fmap Just $ shareDoc $ layoutPat fPat
return (lrdrNameToText lnameF, fExpDoc)
Seq.singleton <$> docSeq
[ appSep $ docLit t
@ -111,11 +111,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
| dotdoti == length fs -> do
-- Abc { a = locA, .. }
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutPat fPat
else Just <$> shareDoc (layoutPat fPat)
return (lrdrNameToText lnameF, fExpDoc)
Seq.singleton <$> docSeq
[ appSep $ docLit t
@ -142,7 +142,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
SigPat _ pat1 (HsPS _ ty1) -> do
-- i :: Int -> expr
patDocs <- layoutPat pat1
tyDoc <- docSharedWrapper layoutType ty1
tyDoc <- shareDoc $ layoutType ty1
case Seq.viewr patDocs of
Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"
xR Seq.:> xN -> do
@ -169,14 +169,23 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
LazyPat _ pat1 -> do
-- ~nestedpat -> expr
wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do
NPat _ _llit@(L _ ol) mNegative _ -> do
-- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
-- TODO92 we had `docWrapNode llit` below, but I don't think that is
-- necessary/possible any longer..
litDoc <- allocateNode $ overLitValBriDoc $ GHC.ol_val ol
negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc]
Nothing -> Seq.singleton litDoc
ViewPat epAnn pat1 pat2 -> do
pat1Doc <- docHandleComms epAnn $ layoutExpr pat1
let arrowLoc = obtainAnnPos epAnn AnnRarrow
pat1DocC <- appSep $ pure pat1Doc
pat2Docs <- layoutPat pat2
arrowDoc <- docHandleComms arrowLoc $ appSep $ docLitS "->"
pure $ pat1DocC Seq.<| arrowDoc Seq.<| pat2Docs
_ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered

73
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs → source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs
View File

@ -2,34 +2,36 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Brittany.Internal.Layouters.Stmt where
module Language.Haskell.Brittany.Internal.ToBriDoc.Stmt where
import qualified Data.Semigroup as Semigroup
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.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr
import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt :: GuardLStmt GhcPs -> ToBriDocM BriDocNumbered
layoutStmt lstmt@(L _ stmt) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
indentAmount :: Int <-
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
docWrapNode lstmt $ case stmt of
LastStmt _ body Nothing _ -> do
layoutExpr body
BindStmt _ lPat expr -> do
case stmt of
LastStmt NoExtField body Nothing _ -> do
-- at least the "|" of a monadcomprehension for _some_ reason
-- is connected to the _body_ of the "result" stmt. So we need
-- to docHandleListElemComms here..
docHandleListElemComms layoutExpr body
BindStmt epAnn lPat expr -> docHandleComms epAnn $ do
patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
expDoc <- shareDoc $ layoutExpr expr
docAlt
[ docCols
ColBindStmt
@ -46,14 +48,14 @@ layoutStmt lstmt@(L _ stmt) = do
$ docPar (docLit $ Text.pack "<-") (expDoc)
]
]
LetStmt _ binds -> do
LetStmt epAnn binds -> docHandleComms epAnn $ do
let isFree = indentPolicy == IndentPolicyFree
let indentFourPlus = indentAmount >= 4
layoutLocalBinds binds >>= \case
Nothing -> docLit $ Text.pack "let"
-- i just tested the above, and it is indeed allowed. heh.
Just [] -> docLit $ Text.pack "let" -- this probably never happens
Just [bindDoc] -> docAlt
Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens
Just (_, [bindDoc]) -> docAlt
[ -- let bind = expr
docCols
ColDoLet
@ -73,7 +75,7 @@ layoutStmt lstmt@(L _ stmt) = do
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc)
]
Just bindDocs -> runFilteredAlternative $ do
Just (_, bindDocs) -> runFilteredAlternative $ do
-- let aaa = expra
-- bbb = exprb
-- ccc = exprc
@ -94,23 +96,24 @@ layoutStmt lstmt@(L _ stmt) = do
$ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1
-- stmt2
-- stmt3
addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq
[ docLit (Text.pack "rec")
, docSeparator
, docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
]
-- rec
-- stmt1
-- stmt2
-- stmt3
addAlternative $ docAddBaseY BrIndentRegular $ docPar
(docLit (Text.pack "rec"))
(docLines $ layoutStmt <$> stmts)
BodyStmt _ expr _ _ -> do
expDoc <- docSharedWrapper layoutExpr expr
RecStmt epAnn (L _ stmts) _ _ _ _ _ ->
docHandleComms epAnn $ runFilteredAlternative $ do
-- rec stmt1
-- stmt2
-- stmt3
addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq
[ docLit (Text.pack "rec")
, docSeparator
, docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
]
-- rec
-- stmt1
-- stmt2
-- stmt3
addAlternative $ docAddBaseY BrIndentRegular $ docPar
(docLit (Text.pack "rec"))
(docLines $ layoutStmt <$> stmts)
BodyStmt NoExtField expr _ _ -> do
expDoc <- shareDoc $ layoutExpr expr
docAddBaseY BrIndentRegular $ expDoc
_ -> briDocByExactInlineOnly "some unknown statement" lstmt

11
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot Normal file
View File

@ -0,0 +1,11 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.ToBriDoc.Stmt where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
layoutStmt :: GuardLStmt GhcPs -> ToBriDocM BriDocNumbered

535
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs Normal file
View File

@ -0,0 +1,535 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.ToBriDoc.Type where
import qualified Data.Text as Text
import GHC (GenLocated(L))
import GHC.Hs
import GHC.Types.Var(Specificity)
import GHC.Types.SourceText(SourceText(SourceText, NoSourceText))
import qualified GHC.OldList as List
import GHC.Types.Basic
import GHC.Utils.Outputable (ftext, showSDocUnsafe)
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast)
layoutSigType :: ToBriDoc HsSigType
-- TODO92 we ignore an ann here
layoutSigType (L _ (HsSig _ outerVarBind typ)) = case outerVarBind of
HsOuterImplicit _ -> layoutType typ
HsOuterExplicit _ bndrs -> do
parts <- splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ
joinSplitArrowType (hasAnyCommentsBelow typ) parts
splitArrowType
:: LHsType GhcPs
-> ToBriDocM
(ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
splitArrowType ltype@(L _ typ) = case typ of
HsForAllTy NoExtField hsf typ1 ->
splitHsForallTypeFromBinders (getBinders hsf) typ1
HsQualTy NoExtField ctxMay typ1 -> do
(innerHead, innerBody) <- splitArrowType typ1
pure
$ ( do
cntxtDocs <- case ctxMay of
Nothing -> pure []
Just (L _ ctxs) -> ctxs `forM` (shareDoc . layoutType)
case cntxtDocs of
[] -> docLit $ Text.pack "()"
[x] -> x
docs -> docAlt
[ let
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list =
List.intersperse docCommaSep $ docForceSingleline <$> docs
in
docSeq ([open] ++ list ++ [close])
, let open = docCols
ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head docs
]
close = docLit $ Text.pack ")"
list = List.tail docs <&> \cntxtDoc -> docCols
ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
in docPar open $ docLines $ list ++ [close]
]
, (("=>", innerHead) : innerBody)
)
HsFunTy epAnn _ typ1 typ2 -> do
(typ1Doc, (innerHead, innerBody)) <- do
let
wrapper = case epAnn of
EpAnn _ AddSemiAnn{} _ ->
error "brittany internal error: HsFunTy EpAnn"
EpAnn _ AddCommaAnn{} _ ->
error "brittany internal error: HsFunTy EpAnn"
EpAnn _ AddVbarAnn{} _ ->
error "brittany internal error: HsFunTy EpAnn"
EpAnn _ (AddRarrowAnn loc) _ ->
docFlushCommsPost (Just $ epaLocationRealSrcSpanStart loc)
EpAnn _ AddRarrowAnnU{} _ ->
error "brittany internal error: HsFunTy EpAnn"
EpAnn _ AddLollyAnnU{} _ ->
error "brittany internal error: HsFunTy EpAnn"
EpAnnNotUsed -> id
typ1Doc <- docHandleComms epAnn $ wrapper $ layoutType typ1
typ2Tuple <- splitArrowType typ2
pure (typ1Doc, typ2Tuple)
pure $ (pure typ1Doc, ("->", innerHead) : innerBody)
_ -> pure (layoutType ltype, [])
splitHsForallTypeFromBinders
:: [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
-> ToBriDocM
(ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
splitHsForallTypeFromBinders binders typ = do
(innerHead, innerBody) <- splitArrowType typ
pure
$ ( do
tyVarDocs <- layoutTyVarBndrs binders
docAlt
-- :: forall x
-- . x
[ let open = docLit $ Text.pack "forall"
in docSeq (open : processTyVarBndrsSingleline tyVarDocs)
-- :: forall
-- (x :: *)
-- . x
, docPar
(docLit (Text.pack "forall"))
(docLines $ tyVarDocs <&> \case
(tname, Nothing) ->
docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname]
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit $ Text.pack ")"
]
)
]
, (".", innerHead) : innerBody
)
joinSplitArrowType
:: Bool
-> (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
-> ToBriDocM BriDocNumbered
joinSplitArrowType hasComments (dHead, body) =
runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docForceSingleline $ docSeq $ dHead : join
[ [docSeparator, docLit (Text.pack prefix), docSeparator, doc]
| (prefix, doc) <- body
]
addAlternative $ docPar (docSetBaseY dHead) $ docLines
[ docCols
ColTyOpPrefix
[ appSep $ docLit $ Text.pack $ if length prefix < 2
then " " ++ prefix -- special case for "forall dot"
-- in multi-line layout case
else prefix
, docEnsureIndent (BrIndentSpecial (length prefix + 1)) doc
]
| (prefix, doc) <- body
]
layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
HsTyVar epAnn promoted name -> docHandleComms epAnn $ do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of
IsPromoted -> docSeq [docSeparator, docTick, docHandleComms name $ docLit t]
NotPromoted -> docHandleComms name $ docLit t
HsForAllTy{} -> do
parts <- splitArrowType ltype
joinSplitArrowType (hasAnyCommentsBelow typ) parts
HsQualTy{} -> do
parts <- splitArrowType ltype
joinSplitArrowType (hasAnyCommentsBelow typ) parts
HsFunTy{} -> do
parts <- splitArrowType ltype
joinSplitArrowType (hasAnyCommentsBelow typ) parts
HsParTy epAnn typ1 -> docHandleComms epAnn $ do
let (wrapOpen, wrapClose) = case epAnn of
EpAnn _ (AnnParen _ spanOpen spanClose) _ ->
(docHandleComms spanOpen, docHandleComms spanClose)
EpAnnNotUsed -> (id, id)
typeDoc1 <- shareDoc $ layoutType typ1
docAlt
[ docSeq
[ wrapOpen $ docLit $ Text.pack "("
, docForceSingleline typeDoc1
, wrapClose $ docLit $ Text.pack ")"
]
, docPar
(docCols
ColTyOpPrefix
[ wrapOpen $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]
)
(wrapClose $ docLit $ Text.pack ")")
]
HsAppTy NoExtField typ1@(L _ HsAppTy{}) typ2 -> do
let
gather
:: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1
docHead <- shareDoc $ layoutType typHead
docRest <- (shareDoc . layoutType) `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead
: (docRest >>= \d -> [docSeparator, docForceSingleline d])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
HsAppTy NoExtField typ1 typ2 -> do
typeDoc1 <- shareDoc $ layoutType typ1
typeDoc2 <- shareDoc $ layoutType typ2
docAlt
[ docSeq
[docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
]
HsListTy epAnn typ1 -> docHandleComms epAnn $ do
let (wrapOpen, wrapClose) = case epAnn of
EpAnn _ (AnnParen _ spanOpen spanClose) _ ->
(docHandleComms spanOpen, docHandleComms spanClose)
EpAnnNotUsed -> (id, id)
typeDoc1 <- shareDoc $ layoutType typ1
docAlt
[ docSeq
[ wrapOpen $ docLit $ Text.pack "["
, docForceSingleline typeDoc1
, wrapClose $ docLit $ Text.pack "]"
]
, docPar
(docCols
ColTyOpPrefix
[ wrapOpen $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]
)
(wrapClose $ docLit $ Text.pack "]")
]
HsTupleTy epAnn tupleSort typs -> docHandleComms epAnn $ case tupleSort of
HsUnboxedTuple -> unboxed
HsBoxedOrConstraintTuple -> simple
where
unboxed = if null typs
then error "brittany internal error: unboxed unit"
else docWith docParenHashLSep docParenHashRSep
simple = if null typs
then unitL
else docWith (docLit (Text.pack "(")) (docLit (Text.pack ")"))
unitL = docLit $ Text.pack "()"
AnnParen _ open close = anns epAnn
wrapStart = docHandleComms open
wrapEnd = docHandleComms close
docWith start end = do
typDocs <- typs `forM` \ty -> do
shareDoc $ docHandleListElemComms layoutType ty
let
line1 = docCols ColTyOpPrefix [wrapStart $ appSep start, head typDocs]
lines =
List.tail typDocs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> typDocs)
docAlt
[ docSeq
$ [wrapStart start]
++ commaDocs
++ [wrapEnd end]
, docPar
(docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ lines ++ [wrapEnd end])
]
HsOpTy{} -> -- TODO
briDocByExactInlineOnly "HsOpTy{}" ltype
-- HsOpTy typ1 opName typ2 -> do
-- -- TODO: these need some proper fixing. precedences don't add up.
-- -- maybe the parser just returns some trivial right recursion
-- -- parse result for any type level operators.
-- -- need to check how things are handled on the expression level.
-- let opStr = lrdrNameToText opName
-- let opLen = Text.length opStr
-- layouter1@(Layouter desc1 _ _) <- layoutType typ1
-- layouter2@(Layouter desc2 _ _) <- layoutType typ2
-- let line = do -- Maybe
-- l1 <- _ldesc_line desc1
-- l2 <- _ldesc_line desc2
-- let len1 = _lColumns_min l1
-- let len2 = _lColumns_min l2
-- let len = 2 + opLen + len1 + len2
-- return $ LayoutColumns
-- { _lColumns_key = ColumnKeyUnique
-- , _lColumns_lengths = [len]
-- , _lColumns_min = len
-- }
-- let block = do -- Maybe
-- rol1 <- descToBlockStart desc1
-- (min2, max2) <- descToMinMax (1+opLen) desc2
-- let (minR, maxR) = case descToBlockMinMax desc1 of
-- Nothing -> (min2, max2)
-- Just (min1, max1) -> (max min1 min2, max max1 max2)
-- return $ BlockDesc
-- { _bdesc_blockStart = rol1
-- , _bdesc_min = minR
-- , _bdesc_max = maxR
-- , _bdesc_opIndentFloatUp = Just (1+opLen)
-- }
-- return $ Layouter
-- { _layouter_desc = LayoutDesc
-- { _ldesc_line = line
-- , _ldesc_block = block
-- }
-- , _layouter_func = \params -> do
-- remaining <- getCurRemaining
-- let allowSameLine = _params_sepLines params /= SepLineTypeOp
-- case line of
-- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do
-- applyLayouterRestore layouter1 defaultParams
-- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " "
-- applyLayouterRestore layouter2 defaultParams
-- _ -> do
-- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params
-- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2
-- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams
-- layoutWriteNewline
-- layoutWriteAppend $ opStr <> Text.pack " "
-- layoutWriteEnsureBlockPlusN downIndent
-- applyLayouterRestore layouter2 defaultParams
-- { _params_sepLines = SepLineTypeOp
-- , _params_opIndent = Just downIndent
-- }
-- , _layouter_ast = ltype
-- }
HsIParamTy epAnn (L _ (HsIPName ipName)) typ1 -> do
let posColon = obtainAnnPos epAnn AnnDcolon
typeDoc1 <- shareDoc $ layoutType typ1
docHandleComms epAnn $ docAlt
[ docSeq
[ docLitS $ "?" ++ showSDocUnsafe (ftext ipName)
, docHandleComms posColon $ docLitS "::"
, docForceSingleline typeDoc1
]
, docPar
(docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
(docCols
ColTyOpPrefix
[ docHandleComms posColon $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
]
)
]
-- TODO: test KindSig
HsKindSig epAnn typ1 kind1 -> do
let posColon = obtainAnnPos epAnn AnnDcolon
typeDoc1 <- shareDoc $ layoutType typ1
kindDoc1 <- shareDoc $ layoutType kind1
docAlt
[ docSeq
[ docForceSingleline typeDoc1
, docSeparator
, docHandleComms posColon $ docLit $ Text.pack "::"
, docSeparator
, docForceSingleline kindDoc1
]
, docPar
typeDoc1
(docCols
ColTyOpPrefix
[ docHandleComms posColon $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1
]
)
]
HsBangTy{} -> -- TODO
briDocByExactInlineOnly "HsBangTy{}" ltype
-- HsBangTy bang typ1 -> do
-- let bangStr = case bang of
-- HsSrcBang _ unpackness strictness ->
-- (++)
-- (case unpackness of
-- SrcUnpack -> "{-# UNPACK #-} "
-- SrcNoUnpack -> "{-# NOUNPACK #-} "
-- NoSrcUnpack -> ""
-- )
-- (case strictness of
-- SrcLazy -> "~"
-- SrcStrict -> "!"
-- NoSrcStrict -> ""
-- )
-- let bangLen = length bangStr
-- layouter@(Layouter desc _ _) <- layoutType typ1
-- let line = do -- Maybe
-- l <- _ldesc_line desc
-- let len = bangLen + _lColumns_min l
-- return $ LayoutColumns
-- { _lColumns_key = ColumnKeyUnique
-- , _lColumns_lengths = [len]
-- , _lColumns_min = len
-- }
-- let block = do -- Maybe
-- rol <- descToBlockStart desc
-- (minR,maxR) <- descToBlockMinMax desc
-- return $ BlockDesc
-- { _bdesc_blockStart = rol
-- , _bdesc_min = minR
-- , _bdesc_max = maxR
-- , _bdesc_opIndentFloatUp = Nothing
-- }
-- return $ Layouter
-- { _layouter_desc = LayoutDesc
-- { _ldesc_line = line
-- , _ldesc_block = block
-- }
-- , _layouter_func = \_params -> do
-- remaining <- getCurRemaining
-- case line of
-- Just (LayoutColumns _ _ m) | m <= remaining -> do
-- layoutWriteAppend $ Text.pack $ bangStr
-- applyLayouterRestore layouter defaultParams
-- _ -> do
-- layoutWriteAppend $ Text.pack $ bangStr
-- layoutWritePostCommentsRestore ltype
-- applyLayouterRestore layouter defaultParams
-- , _layouter_ast = ltype
-- }
HsSpliceTy{} -> -- TODO
briDocByExactInlineOnly "HsSpliceTy{}" ltype
HsDocTy{} -> -- TODO
briDocByExactInlineOnly "HsDocTy{}" ltype
HsRecTy{} -> -- TODO
briDocByExactInlineOnly "HsRecTy{}" ltype
HsExplicitListTy epAnn _ typs -> docHandleComms epAnn $ do
typDocs <- typs `forM` (shareDoc . docHandleListElemComms layoutType)
let hasComments = hasAnyCommentsBelow ltype
let specialCommaSep = appSep $ docLit $ Text.pack " ,"
docAlt
[ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
++ [docLit $ Text.pack "]"]
, case splitFirstLast typDocs of
FirstLastEmpty -> docSeq
[ docLit $ Text.pack "'[]" -- TODO92 comments AnnOpenS
]
FirstLastSingleton e -> docAlt
[ docSeq
[ docLit $ Text.pack "'["
, docForceSingleline e -- TODO92 comments AnnOpenS
, docLit $ Text.pack "]"
]
, docSetBaseY $ docLines
[ docSeq
[ docLit $ Text.pack "'["
, docSeparator
, docSetBaseY $ e -- TODO92 comments AnnOpenS
]
, docLit $ Text.pack " ]"
]
]
FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [eN]) -- TODO92 comments AnnOpenS
)
++ [docLit $ Text.pack " ]"]
addAlternative
$ let
start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
lineN = docCols
ColList
[specialCommaSep, eN] -- TODO92 comments AnnOpenS
end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
]
HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
HsTyLit _ lit -> case lit of
HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsNumTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsCharTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsCharTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> docLit $ Text.pack "_"
HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do
if isUnicode
then docLit $ Text.pack "\x2605" -- Unicode star
else docLit $ Text.pack "*"
XHsType{} -> error "brittany internal error: XHsType"
HsAppKindTy _ ty kind -> do
t <- shareDoc $ layoutType ty
k <- shareDoc $ layoutType kind
docAlt
[ docSeq
[ docForceSingleline t
, docSeparator
, docLit $ Text.pack "@"
, docForceSingleline k
]
, docPar t (docSeq [docLit $ Text.pack "@", k])
]
layoutTyVarBndrs
:: [LHsTyVarBndr () GhcPs]
-> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]
layoutTyVarBndrs = mapM $ \case
(L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ _ lrdrName kind)) -> do
d <- shareDoc $ layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
-- there is no specific reason this returns a list instead of a single
-- BriDoc node.
processTyVarBndrsSingleline
:: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]
processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
(tname, Nothing) -> [docSeparator, docLit tname]
(tname, Just doc) ->
[ docSeparator
, docLit $ Text.pack "(" <> tname <> Text.pack " :: "
, docForceSingleline $ doc
, docLit $ Text.pack ")"
]
getBinders :: HsForAllTelescope GhcPs -> [LHsTyVarBndr () GhcPs]
getBinders x = case x of
HsForAllVis _ b -> b
HsForAllInvis _ b -> fmap withoutSpecificity b
withoutSpecificity :: LHsTyVarBndr GHC.Types.Var.Specificity GhcPs -> LHsTyVarBndr () GhcPs
withoutSpecificity = fmap $ \case
UserTyVar a _ c -> UserTyVar a () c
KindedTyVar a _ c d -> KindedTyVar a () c d

99
source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs → source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs
View File

@ -1,29 +1,55 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Haskell.Brittany.Internal.Transformations.Alt where
module Language.Haskell.Brittany.Internal.Transformations.T1_Alt where
import qualified Control.Monad.Memo as Memo
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.HList.ContainsType
import qualified Data.List.Extra
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified GHC.OldList as List
import qualified Data.Strict.Maybe as Strict
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Components.BriDoc
-- import Language.Haskell.Brittany.Internal.Utils
data VerticalSpacingPar
= VerticalSpacingParNone -- no indented lines
| VerticalSpacingParSome Int -- indented lines, requiring this much
-- vertical space at most
| VerticalSpacingParAlways Int -- indented lines, requiring this much
-- vertical space at most, but should
-- be considered as having space for
-- any spacing validity check.
-- TODO: it might be wrong not to extend "always" to the none case, i.e.
-- we might get better properties of spacing operators by having a
-- product like (Normal|Always, None|Some Int).
deriving (Eq, Show)
data VerticalSpacing
= VerticalSpacing
{ _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool
}
deriving (Eq, Show)
newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
deriving (Functor, Applicative, Monad, Show, Alternative)
pattern LineModeValid :: forall t. t -> LineModeValidity t
pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid :: forall t. LineModeValidity t
pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line
, _acp_indent :: Int -- current indentation level
@ -108,7 +134,7 @@ transformAlts =
-- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd
-- BDExternal k ks c t -> return $ BDFExternal k ks c t
-- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd
-- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd
-- BDAnnotationPost annKey bd -> BDFAnnotationPost annKey <$> go bd
-- BDLines lines -> BDFLines <$> go `mapM` lines
-- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd
-- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd
@ -267,18 +293,18 @@ transformAlts =
return $ x
BDFExternal{} -> processSpacingSimple bdX $> bdX
BDFPlain{} -> processSpacingSimple bdX $> bdX
BDFAnnotationPrior annKey bd -> do
acp <- mGet
mSet
$ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
bd' <- rec bd
return $ reWrap $ BDFAnnotationPrior annKey bd'
BDFAnnotationRest annKey bd ->
reWrap . BDFAnnotationRest annKey <$> rec bd
BDFAnnotationKW annKey kw bd ->
reWrap . BDFAnnotationKW annKey kw <$> rec bd
BDFMoveToKWDP annKey kw b bd ->
reWrap . BDFMoveToKWDP annKey kw b <$> rec bd
BDFQueueComments comms bd ->
reWrap . BDFQueueComments comms <$> rec bd
BDFFlushCommentsPrior loc bd ->
-- TODO92 for AnnotationPrior we had this here:
-- > acp <- mGet
-- > mSet
-- > $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
-- > bd' <- rec bd
-- not sure if the lineModeDecay is relevant any longer though..
reWrap . BDFFlushCommentsPrior loc <$> rec bd
BDFFlushCommentsPost loc bd ->
reWrap . BDFFlushCommentsPost loc <$> rec bd
BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.
BDFLines (l : lr) -> do
ind <- _acp_indent <$> mGet
@ -456,21 +482,21 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParNone -> mVs
_ -> LineModeInvalid
BDFForwardLineMode bd -> rec bd
BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of
BDFExternal _ txt -> return $ LineModeValid $ case Text.lines txt of
[t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
_ -> VerticalSpacing 999 VerticalSpacingParNone False
BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of
[t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
_ -> VerticalSpacing 999 VerticalSpacingParNone False
BDFAnnotationPrior _annKey bd -> rec bd
BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFQueueComments _comms bd -> rec bd
BDFFlushCommentsPrior _loc bd -> rec bd
BDFFlushCommentsPost _loc bd -> rec bd
BDFLines [] ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
BDFLines ls@(_ : _) -> do
lSps <- rec `mapM` ls
let (mVs : _) = lSps -- separated into let to avoid MonadFail
BDFLines (l1 : lR) -> do
mVs <- rec l1
mVRs <- rec `mapM` lR
let lSps = mVs : mVRs
return
$ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
| VerticalSpacing lsp _ _ <- mVs
@ -751,7 +777,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
mVs <- filterAndLimit <$> rec bd
return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForwardLineMode bd -> rec bd
BDFExternal _ _ _ txt | [t] <- Text.lines txt ->
BDFExternal _ txt | [t] <- Text.lines txt ->
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout
-- this.
@ -764,10 +790,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True
| allowHangingQuasiQuotes
]
BDFAnnotationPrior _annKey bd -> rec bd
BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFQueueComments _comms bd -> rec bd
BDFFlushCommentsPrior _loc bd -> rec bd
BDFFlushCommentsPost _loc bd -> rec bd
BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLines ls@(_ : _) -> do
-- we simply assume that lines is only used "properly", i.e. in

154
source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs → source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs
View File

@ -1,14 +1,12 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Transformations.Floating where
module Language.Haskell.Brittany.Internal.Transformations.T2_Floating where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Components.BriDoc
@ -29,68 +27,48 @@ transformSimplifyFloating = stepBO .> stepFull
-- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence
-- the push/pop cases would need to be copied over
where
descendPrior = transformDownMay $ \case
descendCommsPrior = transformDownMay $ \case
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
BDAnnotationPrior annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationPrior annKey1 x
BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) ->
Just $ BDFlushCommentsPrior (max loc1 loc2) x
BDFlushCommentsPrior loc1 (BDPar ind line indented) ->
Just $ BDPar ind (BDFlushCommentsPrior loc1 line) indented
BDFlushCommentsPrior loc1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDFlushCommentsPrior loc1 l : lr)
BDFlushCommentsPrior loc1 (BDLines (l : lr)) ->
Just $ BDLines (BDFlushCommentsPrior loc1 l : lr)
BDFlushCommentsPrior loc1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDFlushCommentsPrior loc1 l : lr)
BDFlushCommentsPrior loc1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDFlushCommentsPrior loc1 x
BDFlushCommentsPrior loc1 (BDDebug s x) ->
Just $ BDDebug s $ BDFlushCommentsPrior loc1 x
_ -> Nothing
descendRest = transformDownMay $ \case
descendCommsPost = transformDownMay $ \case
-- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) ->
BDFlushCommentsPost loc1 (BDFlushCommentsPost loc2 x) ->
Just $ BDFlushCommentsPost (max loc1 loc2) x
BDFlushCommentsPost loc1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost loc1 indented
BDFlushCommentsPost loc1 (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
++ [BDFlushCommentsPost loc1 $ List.last list]
BDFlushCommentsPost loc1 (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
++ [BDFlushCommentsPost loc1 $ List.last list]
BDFlushCommentsPost loc1 (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationRest annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationRest annKey1 x
_ -> Nothing
descendKW = transformDownMay $ \case
-- post floating in
BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
BDAnnotationKW annKey1 kw (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDAnnotationKW annKey1 kw (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
++ [BDFlushCommentsPost loc1 $ List.last cols]
BDFlushCommentsPost loc1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 x
BDFlushCommentsPost loc1 (BDDebug s x) ->
Just $ BDDebug s $ BDFlushCommentsPost loc1 x
_ -> Nothing
descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
@ -124,12 +102,12 @@ transformSimplifyFloating = stepBO .> stepFull
-- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDFlushCommentsPrior loc x) ->
Just $ BDFlushCommentsPrior loc (BDAddBaseY ind x)
BDAddBaseY ind (BDFlushCommentsPost loc x) ->
Just $ BDFlushCommentsPost loc (BDAddBaseY ind x)
BDAddBaseY ind (BDQueueComments comms x) ->
Just $ BDQueueComments comms (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} -> Just $ lit
@ -149,9 +127,9 @@ transformSimplifyFloating = stepBO .> stepFull
transformUp f
where
f = \case
x@BDAnnotationPrior{} -> descendPrior x
x@BDAnnotationKW{} -> descendKW x
x@BDAnnotationRest{} -> descendRest x
BDSeq xs -> BDSeq (dropWhile (\case BDEmpty -> True; _ -> False) xs)
x@BDFlushCommentsPrior{} -> descendCommsPrior x
x@BDFlushCommentsPost{} -> descendCommsPost x
x@BDAddBaseY{} -> descendAddB x
x@BDBaseYPushCur{} -> descendBYPush x
x@BDBaseYPop{} -> descendBYPop x
@ -160,6 +138,10 @@ transformSimplifyFloating = stepBO .> stepFull
x -> x
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
Uniplate.rewrite $ \case
BDSeq (BDEmpty : x) -> Just (BDSeq x)
-- TODO92 This could be rewritten, so that we re-use the
-- (BriDoc -> Maybe Bridoc) part of the descend* functions instead of
-- copying them here (incompletely).
BDAddBaseY BrIndentNone x -> Just $ x
-- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) ->
@ -176,15 +158,6 @@ transformSimplifyFloating = stepBO .> stepFull
BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr)
-- EnsureIndent float-in
-- BDEnsureIndent indent (BDCols sig (col:colr)) ->
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
@ -192,22 +165,23 @@ transformSimplifyFloating = stepBO .> stepFull
-- unaffected.
-- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
-- flush-prior floating in
BDFlushCommentsPrior loc (BDPar ind line indented) ->
Just $ BDPar ind (BDFlushCommentsPrior loc line) indented
BDFlushCommentsPrior loc (BDSeq (l : lr)) ->
Just $ BDSeq (BDFlushCommentsPrior loc l : lr)
BDFlushCommentsPrior loc (BDLines (l : lr)) ->
Just $ BDLines (BDFlushCommentsPrior loc l : lr)
BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-- flush-post floating in
BDFlushCommentsPost comms1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost comms1 indented
BDFlushCommentsPost loc (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDLines list) -> Just
$ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDCols sig list) -> Just
$ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
_ -> Nothing

19
source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs → source/library/Language/Haskell/Brittany/Internal/Transformations/T3_Par.hs
View File

@ -1,11 +1,10 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Transformations.Par where
module Language.Haskell.Brittany.Internal.Transformations.T3_Par where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Components.BriDoc
@ -16,7 +15,12 @@ transformSimplifyPar = transformUp $ \case
-- Just $ BDLines [line, indented]
-- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 ->
-- Just $ BDPar ind1 line (BDLines [p1, p2])
-- TODO92 is this still necessary? No tests fail, but maybe
-- performance gets worse.
x@(BDPar _ (BDPar _ BDPar{} _) _) -> x
-- this is a combination of other transformations below, the
-- important one is the next one.
BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 ->
@ -29,13 +33,16 @@ transformSimplifyPar = transformUp $ \case
_ -> False
)
lines
-> case go lines of
-> case lines >>= flattenToDocList of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
where
go = (=<<) $ \case
BDLines l -> go l
flattenToDocList = \case
-- note that this is a transformUp, so we create the invariant that
-- BDLines does not contain BDEmpty or BDLines, but we may assume the
-- BDLines below are already flattened.
BDLines xs -> xs
BDEmpty -> []
x -> [x]
BDLines [] -> BDEmpty

62
source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs → source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Transformations.Columns where
module Language.Haskell.Brittany.Internal.Transformations.T4_Columns where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
@ -32,6 +32,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
| all
(\case
BDSeparator -> True
BDFlushCommentsPrior _ BDSeparator -> True
BDFlushCommentsPost _ BDSeparator -> True
_ -> False
)
rest
@ -47,41 +49,20 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l
x -> [x]
-- prior floating in
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
-- post floating in
BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
-- flush-prior floating in
BDFlushCommentsPrior loc (BDSeq (l : lr)) ->
Just $ BDSeq (BDFlushCommentsPrior loc l : lr)
BDFlushCommentsPrior loc (BDLines (l : lr)) ->
Just $ BDLines (BDFlushCommentsPrior loc l : lr)
BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-- flush-post floating in
BDFlushCommentsPost loc (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDLines list) -> Just
$ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDCols sig list) -> Just
$ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
-- ensureIndent float-in
-- not sure if the following rule is necessary; tests currently are
-- unaffected.
@ -151,10 +132,9 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDExternal{} -> Nothing
BDPlain{} -> Nothing
BDLines{} -> Nothing
BDAnnotationPrior{} -> Nothing
BDAnnotationKW{} -> Nothing
BDAnnotationRest{} -> Nothing
BDMoveToKWDP{} -> Nothing
BDQueueComments{} -> Nothing
BDFlushCommentsPrior{} -> Nothing
BDFlushCommentsPost{} -> Nothing
BDEnsureIndent{} -> Nothing
BDSetParSpacing{} -> Nothing
BDForceParSpacing{} -> Nothing

15
source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs → source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.Transformations.Indent where
module Language.Haskell.Brittany.Internal.Transformations.T5_Indent where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
@ -16,6 +16,7 @@ import Language.Haskell.Brittany.Internal.Types
transformSimplifyIndent :: BriDoc -> BriDoc
transformSimplifyIndent = Uniplate.rewrite $ \case
BDPar ind (BDLines lines) indented ->
-- error "foo"
Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]
BDPar ind (BDCols sig cols) indented ->
Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])
@ -39,12 +40,10 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
BDLines l -> l
x -> [x]
BDLines [l] -> Just l
BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i x)
BDAddBaseY i (BDAnnotationKW k kw x) ->
Just $ BDAnnotationKW k kw (BDAddBaseY i x)
BDAddBaseY i (BDAnnotationRest k x) ->
Just $ BDAnnotationRest k (BDAddBaseY i x)
BDAddBaseY i (BDFlushCommentsPrior c x) ->
Just $ BDFlushCommentsPrior c (BDAddBaseY i x)
BDAddBaseY i (BDFlushCommentsPost c x) ->
Just $ BDFlushCommentsPost c (BDAddBaseY i x)
BDAddBaseY i (BDSeq l) ->
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY i (BDCols sig l) ->

594
source/library/Language/Haskell/Brittany/Internal/Types.hs
View File

@ -1,118 +1,197 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
module Language.Haskell.Brittany.Internal.Types where
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.Data
import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict
import qualified GHC.OldList as List
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
import GHC ( Anno
, DeltaPos
( DifferentLine
, SameLine
)
, EpaCommentTok
, LHsDecl
, ParsedSource
, XRec
, LImportDecl
)
import GHC.Utils.Outputable(Outputable)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint (AnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Types (Anns)
import qualified Safe
import Language.Haskell.Brittany.Internal.Components.BriDoc
data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe)
, _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)
}
deriving Data.Data.Data
type PPM = MultiRWSS.MultiRWS
'[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String]
'[]
-- brittany-internal error type, part of the brittany library public interface.
data BrittanyError
= ErrorInput String
-- ^ parsing failed
| ErrorUnusedComment String
-- ^ internal error: some comment went missing. Since ghc-9.2 the one below
-- is used for missing comments while layouting top-level decls.
-- You might still get thse for import/export statement comments (right?)
-- (TODO this needs updating once the ghc-9.2 implementation is complete)
| ErrorUnusedComments (LHsDecl GhcPs) Int Int
-- ^ internal error: some comments went missing while layouting the
-- specified top-level declaration (module child).
| ErrorMacroConfig String String
-- ^ in-source config string parsing error; first argument is the parser
-- output and second the corresponding, ill-formed input.
| LayoutWarning String
-- ^ some warning
| forall ast . (Data.Data.Data (XRec GhcPs ast), Outputable (Anno ast)) => ErrorUnknownNode String (XRec GhcPs ast)
-- ^ internal error: pretty-printing is not implemented for type of node
-- in the syntax-tree
| ErrorOutputCheck
-- ^ checking the output for syntactic validity failed
-- General-purpose structure. Church-encoded version of a list that has a
-- parameterized final value.
-- That is:
-- 1) Start with a dumb old `List a = Cons a (List a) | Empty`
-- 2) Parameterize the empty `ListEnd a b = Cons a (List a b) | Final b`
-- 3) Church-encode the result for good measure (and better perf?)
--
-- This is similar to a Writer Monad, and maybe it already exists somewhere,
-- but it feels like a) This abstraction doesn't leak by itself b) you can
-- trivially turn it into something that streams into some "consuming" monadic
-- action c) it is _simple_, doesn't require a monoid or anything without
-- losing anything.
data FinalList a b = FinalList (forall r . (a -> r -> r) -> (b -> r) -> r)
finalPure :: b -> FinalList a b
finalPure b = FinalList $ \_ f -> f b
finalCons :: a -> FinalList a b -> FinalList a b
finalCons a (FinalList l) = FinalList (\f1 f2 -> f1 a $ l f1 f2)
finalBind :: FinalList a b -> (b -> FinalList a b) -> FinalList a b
finalBind (FinalList l) f =
FinalList (\f1 f2 -> l f1 (\b -> let FinalList c = (f b) in c f1 f2))
_finalSingleton :: a -> b -> FinalList a b
_finalSingleton a b = FinalList (\f1 f2 -> f1 a (f2 b))
_finalLMap :: (a -> a') -> FinalList a b -> FinalList a' b
_finalLMap f (FinalList l) = FinalList (\f1 f2 -> l (f1 . f) f2)
_finalRMap :: (b -> b') -> FinalList a b -> FinalList a b'
_finalRMap f (FinalList l) = FinalList (\f1 f2 -> l f1 (f2 . f))
finalYield :: a -> FinalList a ()
finalYield x = FinalList $ \f1 f2 -> f1 x (f2 ())
finalToList_ :: FinalList a () -> [a]
finalToList_ (FinalList l) = l (:) (\() -> [])
finalToList :: FinalList a b -> ([a], b)
finalToList (FinalList l) = l (\x (a, b) -> (x:a, b)) (\b -> ([], b))
instance Functor (FinalList a) where
fmap = _finalRMap
instance Applicative (FinalList a) where
pure = finalPure
FinalList ff <*> FinalList fx =
FinalList $ \f1 f2 -> ff f1 (\g -> fx f1 (f2 . g))
instance Monad (FinalList a) where
FinalList fx >>= f =
FinalList $ \f1 f2 -> fx f1 (\x -> let FinalList c = f x in c f1 f2)
-- After parsing, we split a module into a series of these so that
-- we can process them independently.
data ModuleElement
= MEExactModuleHead ParsedSource
-- ^ When not pretty-printing the module head:
-- module name, imports, exports, but without decls.
-- Could split out the relevant fields, but we need the full (with decls
-- set to []) for exactprinting anyway.
| MEPrettyModuleHead ParsedSource
-- ^ Similar, but when pretty-printing the head:
-- This encompasses just the module name, the exports and
-- the where keyword. Everything else (including comments in
-- various places) get
| MEImportDecl (LImportDecl GhcPs) [(Int, EpaCommentTok)]
-- ^ an import decl, only occurs if pretty-printing the module head.
| MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)]
-- ^ a top-level declaration
| MEComment (Int, EpaCommentTok)
-- ^ a top-level comment, i.e. a comment located between top-level elements
-- (and not associated to some nested node, which might in theory happen).
-- The Int carries the indentation of the comment.
| MEWhitespace DeltaPos
-- ^ Empty lines around decls.
newtype TraceFunc = TraceFunc { useTraceFunc :: String -> IO () }
type PPMLocal = MultiRWSS.MultiRWS
'[Config, ExactPrint.Anns]
'[Config, TraceFunc]
'[Text.Builder.Builder, [BrittanyError], Seq String]
'[]
'[CommentCounter]
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
-- type LayoutConstraints m
-- = ( MonadMultiReader Config m
-- , MonadMultiWriter TextL.Builder.Builder m
-- , MonadMultiWriter (Seq String) m
-- , MonadMultiState LayoutState m
-- , MonadMultiState CommentCounter m
-- , MonadMultiState [GHC.LEpaComment] m
-- )
data LayoutState = LayoutState
{ _lstate_baseYs :: [Int]
-- ^ stack of number of current indentation columns
-- (not number of indentations).
, _lstate_curYOrAddNewline :: Either Int Int
-- ^ Either:
-- 1) number of chars in the current line.
-- 2) number of newlines to be inserted before inserting any
-- non-space elements.
, _lstate_indLevels :: [Int]
-- ^ stack of current indentation levels. set for
-- any layout-affected elements such as
-- let/do/case/where elements.
-- The main purpose of this member is to
-- properly align comments, as their
-- annotation positions are relative to the
-- current layout indentation level.
, _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for
-- properly treating cases where comments
-- on the first indented element have an
-- annotation offset relative to the last
-- non-indented element, which is confusing.
, _lstate_comments :: Anns
, _lstate_commentCol :: Maybe Int -- this communicates two things:
-- firstly, that cursor is currently
-- at the end of a comment (so needs
-- newline before any actual content).
-- secondly, the column at which
-- insertion of comments started.
, _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone
-- writes (any non-spaces) in the
-- current line.
-- , _lstate_isNewline :: NewLineState
-- -- captures if the layouter currently is in a new line, i.e. if the
-- -- current line only contains (indentation) spaces.
-- this is mostly superseeded by curYOrAddNewline, iirc.
, _lstate_commentNewlines :: Int -- number of newlines inserted due to
-- move-to-DP at a start of a comment.
-- Necessary because some keyword DPs
-- are relative to the last non-comment
-- entity (for some reason).
-- This is not very strictly reset to 0,
-- so we might in some cases get "artifacts"
-- from previous document elements.
-- But the worst effect at the moment would
-- be that we introduce less newlines on
-- moveToKWDP, which seems harmless enough.
}
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m => GHC.DeltaPos -> m ()
ppmMoveToExactLoc = \case
SameLine c ->
mTell $ Text.Builder.fromString (List.replicate c ' ')
DifferentLine l c -> mTell $ Text.Builder.fromString
(List.replicate l '\n' ++ List.replicate (c - 1) ' ')
lstate_baseY :: LayoutState -> Int
lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs
lstate_indLevel :: LayoutState -> Int
lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
type ToBriDocM = MultiRWSS.MultiRWS
'[Config, TraceFunc] -- reader
'[[BrittanyError], Seq String] -- writer
'[NodeAllocIndex, CommentCounter] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = XRec GhcPs (sym GhcPs) -> ToBriDocM c
type ToBriDocP sym = sym GhcPs -> ToBriDocM BriDocNumbered
newtype CommentCounter = CommentCounter { unCommentCounter :: Int }
deriving (Eq, Ord, Num, Data.Data.Data)
deriving newtype (Show)
-- Why does this live in types? As long as it does, you _have_
-- to remember to call `docFlushRemaining` in combination with this!
briDocMToPPM :: ToBriDocM a -> PPMLocal (a, Int)
briDocMToPPM m = do
readers <- MultiRWSS.mGetRawR
initCount <- MultiRWSS.mGet @CommentCounter
let
(((x, errs), debugs), commentCount) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateAS initCount
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ m
mTell debugs
mTell errs
mSet commentCount
pure (x, length errs)
newtype NodeAllocIndex = NodeAllocIndex Int
-- evil, incomplete Show instance; only for debugging.
instance Show LayoutState where
show state =
"LayoutState"
++ "{baseYs=" ++ show (_lstate_baseYs state)
++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
++ ",indLevels=" ++ show (_lstate_indLevels state)
++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
++ ",commentCol=" ++ show (_lstate_commentCol state)
++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
++ ",commentNewlines=" ++ show (_lstate_commentNewlines state)
++ "}"
-- data NewLineState = NewLineStateInit -- initial state. we do not know if in a
-- -- newline, really. by special-casing
@ -134,330 +213,13 @@ instance Show LayoutState where
-- , _lsettings_initialAnns :: ExactPrint.Anns
-- }
data BrittanyError
= ErrorInput String
-- ^ parsing failed
| ErrorUnusedComment String
-- ^ internal error: some comment went missing
| ErrorMacroConfig String String
-- ^ in-source config string parsing error; first argument is the parser
-- output and second the corresponding, ill-formed input.
| LayoutWarning String
-- ^ some warning
| forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast)
-- ^ internal error: pretty-printing is not implemented for type of node
-- in the syntax-tree
| ErrorOutputCheck
-- ^ checking the output for syntactic validity failed
data BriSpacing = BriSpacing
{ _bs_spacePastLineIndent :: Int -- space in the current,
-- potentially somewhat filled
-- line.
, _bs_spacePastIndent :: Int -- space required in properly
-- indented blocks below the
-- current line.
}
data ColSig
= ColTyOpPrefix
-- any prefixed operator/paren/"::"/..
-- expected to have exactly two colums.
-- e.g. ":: foo"
-- 111222
-- "-> bar asd asd"
-- 11122222222222
| ColPatternsFuncPrefix
-- pattern-part of the lhs, e.g. "func (foo a b) c _".
-- Has variable number of columns depending on the number of patterns.
| ColPatternsFuncInfix
-- pattern-part of the lhs, e.g. "Foo a <> Foo b".
-- Has variable number of columns depending on the number of patterns.
| ColPatterns
| ColCasePattern
| ColBindingLine (Maybe Text)
-- e.g. "func pat pat = expr"
-- 1111111111111222222
-- or "pat | stmt -> expr"
-- 111111111112222222
-- expected to have exactly two columns.
| ColGuard
-- e.g. "func pat pat | cond = ..."
-- 11111111111112222222
-- or "pat | cond1, cond2 -> ..."
-- 1111222222222222222
-- expected to have exactly two columns
| ColGuardedBody
-- e.g. | foofoo = 1
-- | bar = 2
-- 111111111222
-- expected to have exactly two columns
| ColBindStmt
| ColDoLet -- the non-indented variant
| ColRec
| ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
| ColRecDecl
| ColListComp
| ColList
| ColApp Text
| ColTuple
| ColTuples
| ColOpPrefix -- merge with ColList ? other stuff?
| ColImport
-- TODO
deriving (Eq, Ord, Data.Data.Data, Show)
data BrIndent = BrIndentNone
| BrIndentRegular
| BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show)
type ToBriDocM = MultiRWSS.MultiRWS
'[Config, Anns] -- reader
'[[BrittanyError], Seq String] -- writer
'[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c
data DocMultiLine
= MultiLineNo
| MultiLinePossible
deriving (Eq)
-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot
-- of transformations on `BriDocF Identity`s and it is really annoying to
-- `Identity`/`runIdentity` everywhere.
data BriDoc
= -- BDWrapAnnKey AnnKey BriDoc
BDEmpty
| BDLit !Text
| BDSeq [BriDoc] -- elements other than the last should
-- not contains BDPars.
| BDCols ColSig [BriDoc] -- elements other than the last
-- should not contains BDPars
| BDSeparator -- semantically, space-unless-at-end-of-line.
| BDAddBaseY BrIndent BriDoc
| BDBaseYPushCur BriDoc
| BDBaseYPop BriDoc
| BDIndentLevelPushCur BriDoc
| BDIndentLevelPop BriDoc
| BDPar
{ _bdpar_indent :: BrIndent
, _bdpar_restOfLine :: BriDoc -- should not contain other BDPars
, _bdpar_indented :: BriDoc
}
-- | BDAddIndent BrIndent (BriDocF f)
-- | BDNewline
| BDAlt [BriDoc]
| BDForwardLineMode BriDoc
| BDExternal AnnKey
(Set AnnKey) -- set of annkeys contained within the node
-- to be printed via exactprint
Bool -- should print extra comment ?
Text
| BDPlain !Text -- used for QuasiQuotes, content can be multi-line
-- (contrast to BDLit)
| BDAnnotationPrior AnnKey BriDoc
| BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc
| BDAnnotationRest AnnKey BriDoc
| BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset
| BDLines [BriDoc]
| BDEnsureIndent BrIndent BriDoc
-- the following constructors are only relevant for the alt transformation
-- and are removed afterwards. They should never occur in any BriDoc
-- after the alt transformation.
| BDForceMultiline BriDoc
| BDForceSingleline BriDoc
| BDNonBottomSpacing Bool BriDoc
| BDSetParSpacing BriDoc
| BDForceParSpacing BriDoc
-- pseudo-deprecated
| BDDebug String BriDoc
deriving (Data.Data.Data, Eq, Ord)
data BriDocF f
= -- BDWrapAnnKey AnnKey BriDoc
BDFEmpty
| BDFLit !Text
| BDFSeq [f (BriDocF f)] -- elements other than the last should
-- not contains BDPars.
| BDFCols ColSig [f (BriDocF f)] -- elements other than the last
-- should not contains BDPars
| BDFSeparator -- semantically, space-unless-at-end-of-line.
| BDFAddBaseY BrIndent (f (BriDocF f))
| BDFBaseYPushCur (f (BriDocF f))
| BDFBaseYPop (f (BriDocF f))
| BDFIndentLevelPushCur (f (BriDocF f))
| BDFIndentLevelPop (f (BriDocF f))
| BDFPar
{ _bdfpar_indent :: BrIndent
, _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars
, _bdfpar_indented :: f (BriDocF f)
}
-- | BDAddIndent BrIndent (BriDocF f)
-- | BDNewline
| BDFAlt [f (BriDocF f)]
| BDFForwardLineMode (f (BriDocF f))
| BDFExternal AnnKey
(Set AnnKey) -- set of annkeys contained within the node
-- to be printed via exactprint
Bool -- should print extra comment ?
Text
| BDFPlain !Text -- used for QuasiQuotes, content can be multi-line
-- (contrast to BDLit)
| BDFAnnotationPrior AnnKey (f (BriDocF f))
| BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))
| BDFAnnotationRest AnnKey (f (BriDocF f))
| BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset
| BDFLines [(f (BriDocF f))]
| BDFEnsureIndent BrIndent (f (BriDocF f))
| BDFForceMultiline (f (BriDocF f))
| BDFForceSingleline (f (BriDocF f))
| BDFNonBottomSpacing Bool (f (BriDocF f))
| BDFSetParSpacing (f (BriDocF f))
| BDFForceParSpacing (f (BriDocF f))
| BDFDebug String (f (BriDocF f))
-- deriving instance Data.Data.Data (BriDocF Identity)
deriving instance Data.Data.Data (BriDocF ((,) Int))
type BriDocFInt = BriDocF ((,) Int)
type BriDocNumbered = (Int, BriDocFInt)
instance Uniplate.Uniplate BriDoc where
uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x
uniplate (BDSeq list ) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts ) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x
uniplate (BDAnnotationPrior annKey bd) =
plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationKW annKey kw bd) =
plate BDAnnotationKW |- annKey |- kw |* bd
uniplate (BDAnnotationRest annKey bd) =
plate BDAnnotationRest |- annKey |* bd
uniplate (BDMoveToKWDP annKey kw b bd) =
plate BDMoveToKWDP |- annKey |- kw |- b |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd
newtype NodeAllocIndex = NodeAllocIndex Int
-- TODO: rename to "dropLabels" ?
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
unwrapBriDocNumbered tpl = case snd tpl of
BDFEmpty -> BDEmpty
BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t
BDFPlain t -> BDPlain t
BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd
BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where rec = unwrapBriDocNumbered
isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False
isNotEmpty _ = True
-- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case
BDEmpty -> ()
BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> ()
BDPlain{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing _ bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd
briDocForceSpine :: BriDoc -> BriDoc
briDocForceSpine bd = briDocSeqSpine bd `seq` bd
data VerticalSpacingPar
= VerticalSpacingParNone -- no indented lines
| VerticalSpacingParSome Int -- indented lines, requiring this much
-- vertical space at most
| VerticalSpacingParAlways Int -- indented lines, requiring this much
-- vertical space at most, but should
-- be considered as having space for
-- any spacing validity check.
-- TODO: it might be wrong not to extend "always" to the none case, i.e.
-- we might get better properties of spacing operators by having a
-- product like (Normal|Always, None|Some Int).
deriving (Eq, Show)
data VerticalSpacing
= VerticalSpacing
{ _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool
}
deriving (Eq, Show)
newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
deriving (Functor, Applicative, Monad, Show, Alternative)
pattern LineModeValid :: forall t. t -> LineModeValidity t
pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid :: forall t. LineModeValidity t
pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
-- TODO92 is this old leftover, or useful future idea?
-- data BriSpacing = BriSpacing
-- { _bs_spacePastLineIndent :: Int -- space in the current,
-- -- potentially somewhat filled
-- -- line.
-- , _bs_spacePastIndent :: Int -- space required in properly
-- -- indented blocks below the
-- -- current line.
-- }

40
source/library/Language/Haskell/Brittany/Internal/Util/AST.hs Normal file
View File

@ -0,0 +1,40 @@
{-# 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]
_ -> []

242
source/library/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -12,23 +12,23 @@ import qualified Data.Coerce
import Data.Data
import Data.Generics.Aliases
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import DataTreePrint
import qualified GHC.Data.FastString as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Hs.Extension as HsExtension
import qualified GHC.OldList as List
import GHC.Types.Name.Occurrence as OccName (occNameString)
import GHC.Types.Name.Occurrence (OccName, occNameString)
import qualified GHC.Types.Name.Reader as RdrName (rdrNameOcc)
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Outputable as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified GHC.Parser.Annotation as GHC
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import qualified Text.PrettyPrint as PP
import qualified Data.Semigroup as Semigroup
import qualified System.IO.Unsafe as Unsafe
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Components.BriDoc
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
@ -40,10 +40,10 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords
showSDoc_ :: GHC.SDoc -> String
showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
showSDoc_ = GHC.showSDocUnsafe
showOutputable :: (GHC.Outputable a) => a -> String
showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
showOutputable = GHC.showPprUnsafe
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
@ -55,7 +55,7 @@ fromOptionIdentity x y =
-- maximum monoid over N+0
-- or more than N, because Num is allowed.
newtype Max a = Max { getMax :: a }
deriving (Eq, Ord, Show, Bounded, Num)
deriving (Eq, Ord, Show, Num)
instance (Num a, Ord a) => Semigroup (Max a) where
(<>) = Data.Coerce.coerce (max :: a -> a -> a)
@ -72,75 +72,112 @@ instance Show ShowIsId where
data A x = A ShowIsId x
deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF =
data DeltaComment = DeltaComment GHC.DeltaPos GHC.EpaCommentTok
deriving Data
customLayouterF :: LayouterF
customLayouterF layoutF =
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`ext2Q` located
`extQ` internalLayouterShowIsId
`extQ` internalLayouterFastString
`extQ` internalLayouterBytestring
`extQ` internalLayouterOccName
`extQ` internalLayouterSrcSpan
`extQ` internalLayouterRdrName
`extQ` realSrcSpan
-- `extQ` deltaComment
-- `extQ` anchored
-- `ext1Q` srcSpanAnn
-- `ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
simpleLayouter :: String -> NodeLayouter
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss =
simpleLayouter
-- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{"
++ showOutputable ss
++ "}"
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where
annStr = case cast ss of
Just (s :: GHC.SrcSpan) ->
ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
Nothing -> ShowIsId "nnnnnnnn"
realSrcSpan :: GHC.RealSrcSpan -> NodeLayouter
realSrcSpan span = internalLayouterSimple (show span)
-- anchored :: (Data b) => GHC.GenLocated GHC.Anchor b -> NodeLayouter
-- anchored (GHC.L (GHC.Anchor _ op) a) = f $ GHC.L op a
customLayouterNoSrcSpansF :: LayouterF
customLayouterNoSrcSpansF layoutF =
DataToLayouter
$ f
`extQ` internalLayouterShowIsId
`extQ` internalLayouterFastString
`extQ` internalLayouterBytestring
`extQ` internalLayouterOccName
`extQ` internalLayouterSrcSpan
`extQ` internalLayouterRdrName
`extQ` realSrcSpan
`extQ` deltaComment
`extQ` anchored
`ext1Q` srcSpanAnn
-- `ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
realSrcSpan :: GHC.RealSrcSpan -> NodeLayouter
realSrcSpan span = internalLayouterSimple (show span)
-- anchored :: (Data b) => GHC.GenLocated GHC.Anchor b -> NodeLayouter
-- anchored (GHC.L (GHC.Anchor _ op) a) = f $ GHC.L op a
anchored :: GHC.Anchor -> NodeLayouter
anchored (GHC.Anchor _ op) = f op
srcSpanAnn :: forall a . Data a => GHC.SrcSpanAnn' a -> NodeLayouter
srcSpanAnn (GHC.SrcSpanAnn ann _loc) = f ann
deltaComment :: GHC.LEpaComment -> NodeLayouter
deltaComment (GHC.L anchor (GHC.EpaComment token prior)) =
f (GHC.L (ExactPrint.Utils.ss2deltaEnd prior (GHC.anchor anchor)) token)
-- located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
-- located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
-- where
-- annStr = case cast ss of
-- Just (s :: GHC.SrcSpan) ->
-- ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
-- Nothing -> ShowIsId "nnnnnnnn"
customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF =
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`extQ` internalLayouterShowIsId
`extQ` internalLayouterFastString
`extQ` internalLayouterBytestring
`extQ` internalLayouterOccName
`extQ` internalLayouterSrcSpan
`extQ` internalLayouterRdrName
`ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
simpleLayouter :: String -> NodeLayouter
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a
internalLayouterSimple :: String -> NodeLayouter
internalLayouterSimple s = NodeLayouter (length s) False (const $ PP.text s)
internalLayouterShowIsId :: ShowIsId -> NodeLayouter
internalLayouterShowIsId (ShowIsId s) =
NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a
internalLayouterFastString :: GHC.FastString -> NodeLayouter
internalLayouterFastString =
internalLayouterSimple . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter
internalLayouterBytestring :: B.ByteString -> NodeLayouter
internalLayouterBytestring =
internalLayouterSimple . show :: B.ByteString -> NodeLayouter
internalLayouterSrcSpan :: GHC.SrcSpan -> NodeLayouter
internalLayouterSrcSpan ss =
internalLayouterSimple
-- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{"
++ showOutputable ss
++ "}"
internalLayouterOccName :: OccName -> NodeLayouter
internalLayouterOccName =
internalLayouterSimple . ("{OccName: " ++) . (++ "}") . occNameString
internalLayouterRdrName :: RdrName -> NodeLayouter
internalLayouterRdrName =
internalLayouterSimple . ("{RdrName: " ++) . (++ "}") . occNameString . RdrName.rdrNameOcc
-- displayBriDocTree :: BriDoc -> PP.Doc
-- displayBriDocTree = \case
@ -190,26 +227,19 @@ customLayouterNoAnnsF layoutF =
-- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]
-- ++ [PP.text "]"]
traceIfDumpConf
:: (MonadMultiReader Config m, Show a)
=> String
-> (DebugConfig -> Identity (Semigroup.Last Bool))
-> a
-> m ()
traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
-- traceWhen
-- :: (Show a)
-- => String
-- -> Bool
-- -> a
-- -> IO ()
-- traceWhen s accessor val = do
-- TraceFunc f <- mAsk
-- whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
-- Unsafe.unsafePerformIO $ do
-- f ("---- " ++ s ++ " ----\n" ++ show val)
-- pure $ pure ()
tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow
:: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show
-- i should really put that into multistate..
mModify :: MonadMultiState s m => (s -> s) -> m ()
mModify f = mGet >>= mSet . f
astToDoc :: Data ast => ast -> PP.Doc
astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast
@ -218,17 +248,17 @@ briDocToDoc :: BriDoc -> PP.Doc
briDocToDoc = astToDoc . removeAnnotations
where
removeAnnotations = Uniplate.transform $ \case
BDAnnotationPrior _ x -> x
BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x
BDFlushCommentsPrior _ x -> x
BDFlushCommentsPost _ x -> x
BDQueueComments _ x -> x
x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc =
printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
-- annsDoc :: ExactPrint.Types.Anns -> PP.Doc
-- annsDoc =
-- printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], [])
@ -252,17 +282,6 @@ splitFirstLast [] = FirstLastEmpty
splitFirstLast [x] = FirstLastSingleton x
splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr)
-- TODO: move to uniplate upstream?
-- aka `transform`
transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
transformUp f = g where g = f . Uniplate.descend g
_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
_transformDown f = g where g = Uniplate.descend g . f
transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x
_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x
-- | similar to List.lines, but treating the case of final newline character
-- in such a manner that this function is the inverse of @intercalate "\n"@.
lines' :: String -> [String]
@ -271,5 +290,18 @@ lines' s = case break (== '\n') s of
(s1, [_]) -> [s1, ""]
(s1, (_ : r)) -> s1 : lines' r
absurdExt :: HsExtension.NoExtCon -> a
absurdExt = HsExtension.noExtCon
-- absurdExt :: HsExtension.NoExtCon -> a
-- absurdExt = HsExtension.noExtCon
traceIfDumpConf
:: (MonadMultiReader TraceFunc m, MonadMultiReader Config m, Show a)
=> String
-> (DebugConfig -> Identity (Semigroup.Last Bool))
-> a
-> m ()
traceIfDumpConf s accessor val = do
TraceFunc f <- mAsk
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
Unsafe.unsafePerformIO $ do
f ("---- " ++ s ++ " ----\n" ++ show val)
pure $ pure ()

632
source/library/Language/Haskell/Brittany/Internal/Backend.hs → source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs
View File

@ -1,33 +1,27 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Brittany.Internal.Backend where
module Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
( alignColsLines
)
where
import qualified Control.Monad.Trans.State.Strict as StateS
import qualified Data.Either as Either
import qualified Data.Foldable as Foldable
import qualified Data.IntMap.Lazy as IntMapL
import qualified Data.IntMap.Strict as IntMapS
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
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.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.State.Strict
as StateS
import qualified Data.Either as Either
import qualified Data.Foldable as Foldable
import qualified Data.IntMap.Lazy as IntMapL
import qualified Data.IntMap.Strict as IntMapS
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
import Language.Haskell.Brittany.Internal.WriteBriDoc.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc
@ -60,340 +54,10 @@ instance Show ColInfo where
"ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1
{ _cbs_map :: ColMap1
, _cbs_index :: ColIndex
}
type LayoutConstraints m
= ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
, MonadMultiState LayoutState m
)
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case
BDEmpty -> do
return () -- can it be that simple
BDLit t -> do
layoutIndentRestorePostComment
layoutRemoveIndentLevelLinger
layoutWriteAppend t
BDSeq list -> do
list `forM_` layoutBriDocM
-- in this situation, there is nothing to do about cols.
-- i think this one does not happen anymore with the current simplifications.
-- BDCols cSig list | BDPar sameLine lines <- List.last list ->
-- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
BDCols _ list -> do
list `forM_` layoutBriDocM
BDSeparator -> do
layoutAddSepSpace
BDAddBaseY indent bd -> do
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do
layoutBaseYPushCur
layoutBriDocM bd
BDBaseYPop bd -> do
layoutBriDocM bd
layoutBaseYPop
BDIndentLevelPushCur bd -> do
layoutIndentLevelPushCur
layoutBriDocM bd
BDIndentLevelPop bd -> do
layoutBriDocM bd
layoutIndentLevelPop
BDEnsureIndent indent bd -> do
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteEnsureBlock
layoutBriDocM bd
BDPar indent sameLine indented -> do
layoutBriDocM sameLine
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteNewlineBlock
layoutBriDocM indented
BDLines lines -> alignColsLines lines
BDAlt [] -> error "empty BDAlt"
BDAlt (alt : _) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do
let
tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do
layoutWriteAppend
$ Text.pack
$ "{-"
++ show (annKey, Map.lookup annKey anns)
++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do
layoutWriteAppend $ l
unless (i == tlineCount) layoutWriteNewlineBlock
do
state <- mGet
let filterF k _ = not $ k `Set.member` subKeys
mSet $ state
{ _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state
}
BDPlain t -> do
layoutWriteAppend t
BDAnnotationPrior annKey bd -> do
state <- mGet
let m = _lstate_comments state
let
moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure ()
Right{} -> moveToExactAnn annKey
mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annPriorComments = [] })
annKey
m
}
return mAnn
case mAnn of
Nothing -> moveToExactLocationAction
Just [] -> moveToExactLocationAction
Just priors -> do
-- layoutResetSepSpace
priors
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment
case comment of
('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
-- ^ evil hack for CPP
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
moveToExactLocationAction
layoutBriDocM bd
BDAnnotationKW annKey keyword bd -> do
layoutBriDocM bd
mComments <- do
state <- mGet
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let
mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
Just annR
_ -> Nothing
case mToSpan of
Just anns -> do
let
(comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annsDP = rest })
annKey
m
}
return $ nonEmpty comments
_ -> return Nothing
case mComments of
Nothing -> pure ()
Just comments -> do
comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment
-- evil hack for CPP:
case comment of
('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do
layoutBriDocM bd
annMay <- do
state <- mGet
let m = _lstate_comments state
pure $ Map.lookup annKey m
let mComments = nonEmpty . extractAllComments =<< annMay
let
semiCount = length
[ ()
| Just ann <- [annMay]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
]
shouldAddSemicolonNewlines <-
mAsk
<&> _conf_layout
.> _lconfig_experimentalSemicolonNewlines
.> confUnpack
mModify $ \state -> state
{ _lstate_comments = Map.adjust
(\ann -> ann
{ ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = []
, ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False
_ -> True
}
)
annKey
(_lstate_comments state)
}
case mComments of
Nothing -> do
when shouldAddSemicolonNewlines $ do
[1 .. semiCount] `forM_` const layoutWriteNewline
Just comments -> do
comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack comment
case comment of
('#' : _) -> layoutMoveToCommentPos y (-999) 1
-- ^ evil hack for CPP
")" -> pure ()
-- ^ fixes the formatting of parens
-- on the lhs of type alias defs
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
mDP <- do
state <- mGet
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let
relevant =
[ dp
| Just ann <- [mAnn]
, (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1
]
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
case relevant of
[] -> pure Nothing
(ExactPrint.Types.DP (y, x) : _) -> do
mSet state { _lstate_commentNewlines = 0 }
pure $ Just (y - _lstate_commentNewlines state, x)
case mDP of
Nothing -> pure ()
Just (y, x) ->
-- we abuse this, as we probably will print the KW next, which is
-- _not_ a comment..
layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1
layoutBriDocM bd
BDNonBottomSpacing _ bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd
BDDebug s bd -> do
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd
briDocLineLength :: BriDoc -> Int
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- the state encodes whether a separator was already
-- appended at the current position.
where
rec = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t
BDPlain t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd
BDLines ls@(_ : _) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc
where
rec :: BriDoc -> Bool
rec = \case
BDEmpty -> False
BDLit _ -> False
BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds
BDSeparator -> False
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t | [_] <- Text.lines t -> False
BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd
BDLines (_ : _ : _) -> True
BDLines [_] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd
-- In theory
-- =========
@ -469,25 +133,26 @@ briDocIsMultiLine briDoc = rec briDoc
-- are executed in the same recursion, too.
-- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue
-- mentioned in the first "possible improvement".
alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()
alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
alignColsLines :: LayoutConstraints m => (BriDoc -> m ()) -> [BriDoc] -> m ()
alignColsLines layoutBriDocM bridocs = do -- colInfos `forM_` \colInfo -> do
-- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs))
curX <- do
state <- mGet
return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe
0
(_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
alignBreak <-
mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
case () of
_ -> do
-- tellDebugMess ("colInfos:\n" ++ List.unlines [ "> " ++ prettyColInfos "> " x | x <- colInfos])
-- tellDebugMess ("processedMap: " ++ show processedMap)
sequence_
$ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos
<&> processInfo colMax processedMap
$ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos
<&> processInfo layoutBriDocM colMax processedMap
where
(colInfos, finalState) =
StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)
@ -511,11 +176,11 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
(xN : xR) ->
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
where
fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingLeaf len ) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = {-Foldable.foldl1 maxZipper-}
fmap colAggregation $ transpose $ Foldable.toList colss
@ -524,18 +189,19 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
counter count l = if List.last posXs + List.last l <= colMax
then count + 1
else count
ratio = fromIntegral (foldl counter (0 :: Int) colss)
ratio = fromIntegral (foldl' counter (0 :: Int) colss)
/ fromIntegral (length colss)
in (ratio, maxCols, colss)
in
(ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW
:: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return []
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd : bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW
-- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
(if shouldBreakAfter bd then ColInfoStart else info)
@ -591,7 +257,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case
brdc@(BDCols colSig subDocs)
@ -602,56 +268,26 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs
let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map
s <- StateS.get
let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s
{ _cbs_map = IntMapS.insert
infoInd
(lastFlag, spaces Seq.|> trueSpacings)
m
}
case IntMapS.lookup infoInd m of
Just (_, spaces) -> StateS.put s
{ _cbs_map = IntMapS.insert
infoInd
(lastFlag, spaces Seq.|> trueSpacings)
m
}
Nothing -> pure () -- shouldn't be possible
return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise -> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do
let
isLastList =
if lastFlag then (== length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
withAlloc
:: Bool
-> ( ColIndex
-> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
)
-> StateS.State ColBuildState ColInfo
withAlloc lastFlag f = do
cbs <- StateS.get
let ind = _cbs_index cbs
StateS.put $ cbs { _cbs_index = ind + 1 }
(space, info) <- f ind
StateS.get >>= \c -> StateS.put
$ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
return info
processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()
processInfo maxSpace m = \case
processInfo :: LayoutConstraints m => (BriDoc -> m ()) -> Int -> ColMap2 -> ColInfo -> m ()
processInfo layoutBriDocM maxSpace m = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
@ -660,7 +296,9 @@ processInfo maxSpace m = \case
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do
state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state)
-- ++ " - " ++ show (_lstate_addSepSpace state)
-- ++ " - " ++ show (_lstate_commentCol state))
let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state
return $ case _lstate_curYOrAddNewline state of
Left i -> case _lstate_commentCol state of
@ -669,11 +307,12 @@ processInfo maxSpace m = \case
Right{} -> spaceAdd
let colMax = min colMaxConf (curX + maxSpace)
-- tellDebugMess $ show curX
let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
let (ratio, maxCols1, _colss) = case IntMapS.lookup ind m of
Just x -> x
Nothing -> error "internal brittany error: processInfo bad lookup"
let
maxCols2 = list <&> \case
(_, ColInfo i _ _) ->
let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(_, ColInfo i _ _) | Just (_, ms, _) <- IntMapS.lookup i m -> sum ms
(l, _) -> l
let maxCols = zipWith max maxCols1 maxCols2
let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
@ -701,18 +340,20 @@ processInfo maxSpace m = \case
spacings =
zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs
-- tellDebugMess $ "ind = " ++ show ind
-- tellDebugMess $ "spacings = " ++ show spacings
-- tellDebugMess $ "maxCols = " ++ show maxCols
-- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
-- tellDebugMess $ "list = " ++ show list
-- tellDebugMess $ "maxSpace = " ++ show maxSpace
let
alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
-- tellDebugMess $ "layoutWriteEnsureAbsoluteN " ++ show destX
layoutWriteEnsureAbsoluteN destX
processInfo s m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore)
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
processInfo layoutBriDocM s m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore layoutBriDocM)
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax=" ++ show colMax) $
if List.last fixedPosXs + fst (List.last list) > colMax
-- per-item check if there is overflowing.
-- per-item check if there is overflowing.
then noAlignAct
else alignAct
case alignMode of
@ -725,8 +366,145 @@ processInfo maxSpace m = \case
ColumnAlignModeAnimously -> animousAct
ColumnAlignModeAlways -> alignAct
processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
processInfoIgnore = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
withAlloc
:: Bool
-> ( ColIndex
-> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
)
-> StateS.State ColBuildState ColInfo
withAlloc lastFlag f = do
cbs <- StateS.get
let ind = _cbs_index cbs
StateS.put $ cbs { _cbs_index = ind + 1 }
(space, info) <- f ind
StateS.get >>= \c -> StateS.put
$ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
return info
briDocLineLength :: BriDoc -> Int
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- the state encodes whether a separator was already
-- appended at the current position.
where
rec = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ t -> return $ Text.length t
BDPlain t -> return $ Text.length t
BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ bd -> rec bd
BDLines ls@(_ : _) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc
where
rec :: BriDoc -> Bool
rec = \case
BDEmpty -> False
BDLit _ -> False
BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds
BDSeparator -> False
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ t | [_] <- Text.lines t -> False
BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True
BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ bd -> rec bd
BDLines (_ : _ : _) -> True
BDLines [_] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do
let
isLastList =
if lastFlag then (== length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
processInfoIgnore :: LayoutConstraints m => (BriDoc -> m ()) -> ColInfo -> m ()
processInfoIgnore layoutBriDocM = go
where
go = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> go)
_prettyColInfos :: String -> ColInfo -> String
_prettyColInfos prefix = \case
ColInfoStart -> "start (?)"
ColInfoNo bd -> "X" ++ replicate (briDocLineLength bd - 1) '_'
ColInfo _ind sig below ->
let
(total, belowStrs) = List.mapAccumL
(\x (add, info) ->
(x + add, _prettyColInfos (prefix ++ replicate (x) ' ') info)
)
0
below
in
"X"
++ replicate (total - 1) 'x'
++ " as "
++ show sig
++ " "
++ show _ind
++ "\n"
++ prefix
++ List.concat belowStrs
++ "\n"
++ prefix
++ replicate total ' '
-- [ prefix ++ show k ++ ": " ++ prettyColInfos (prefix ++ " ") v
-- | (k, v) <- below
-- ]

275
source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs → source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs
View File

@ -1,29 +1,24 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Haskell.Brittany.Internal.BackendUtils where
module Language.Haskell.Brittany.Internal.WriteBriDoc.Operators where
import qualified Data.Data
import qualified Data.Either
import qualified Data.Map as Map
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC (Located)
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Data.Maybe
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List
import qualified GHC.Parser.Annotation as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.WriteBriDoc.Types
traceLocal :: (MonadMultiState LayoutState m) => a -> m ()
traceLocal _ = return ()
-- traceLocal :: (MonadMultiState LayoutState m, Show a) => a -> m ()
-- traceLocal x = trace (show x) $ pure ()
layoutWriteAppend
@ -31,8 +26,8 @@ layoutWriteAppend
=> Text
-> m ()
layoutWriteAppend t = do
traceLocal ("layoutWriteAppend", t)
state <- mGet
traceLocal ("layoutWriteAppend", t, _lstate_curYOrAddNewline state, _lstate_addSepSpace state)
case _lstate_curYOrAddNewline state of
Right i -> do
replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"
@ -115,23 +110,31 @@ layoutSetCommentCol = do
-- to be harmless so far..
layoutMoveToCommentPos
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
=> Bool
-> Int
-> Int
-> Int
-> m ()
layoutMoveToCommentPos y x commentLines = do
traceLocal ("layoutMoveToCommentPos", y, x, commentLines)
layoutMoveToCommentPos absolute y x commentLines = do
state <- mGet
traceLocal ("layoutMoveToCommentPos", y, x, commentLines, _lstate_curYOrAddNewline state, _lstate_addSepSpace state, lstate_baseY state)
mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right{} -> Right y
, _lstate_addSepSpace =
Just $ if Data.Maybe.isJust (_lstate_commentCol state)
then case _lstate_curYOrAddNewline state of
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x
else if y == 0 then x else _lstate_indLevelLinger state + x
Just $ if
| y > 0 -> if absolute then x - 1 else lstate_baseY state + x
| Data.Maybe.isNothing (_lstate_commentCol state) -> x
| otherwise -> x
-- TODO92 we had more complex logic here for otherwise previously,
-- but I don't think it can happen. Leaving this here until some
-- more testing is done as a reminder.
-- Also, if this _is_ necessary, the "absolute" handling might to
-- be adapted.
-- case _lstate_curYOrAddNewline state of
-- Left{} -> x
-- Right{} -> _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_commentCol state of
Just existing -> existing
Nothing -> case _lstate_curYOrAddNewline state of
@ -163,8 +166,8 @@ layoutWriteEnsureNewlineBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> m ()
layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock")
state <- mGet
traceLocal ("layoutWriteEnsureNewlineBlock", lstate_baseY state)
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
@ -292,15 +295,20 @@ layoutWithAddBaseColN amount m = do
layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur")
state <- mGet
case _lstate_commentCol state of
Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> layoutBaseYPushInternal (i + j)
(Left i, Nothing) -> layoutBaseYPushInternal i
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol
traceLocal
( "layoutBaseYPushCur"
, _lstate_curYOrAddNewline state
, _lstate_addSepSpace state
)
layoutBaseYPushInternal
(case _lstate_commentCol state of
Nothing -> case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
Just cCol -> cCol + fromMaybe 0 (_lstate_addSepSpace state)
)
layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do
@ -338,39 +346,48 @@ layoutAddSepSpace = do
-- TODO: when refactoring is complete, the other version of this method
-- can probably be removed.
moveToExactAnn
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader (Map AnnKey Annotation) m
)
=> AnnKey
-> m ()
moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey)
anns <- mAsk
case Map.lookup annKey anns of
Nothing -> return ()
Just ann -> do
-- curY <- mGet <&> _lstate_curY
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
-- mModify $ \state -> state { _lstate_addNewline = Just x }
moveToY y
-- moveToExactAnn
-- :: ( MonadMultiWriter Text.Builder.Builder m
-- , MonadMultiState LayoutState m
-- , MonadMultiReader (Map AnnKey Annotation) m
-- )
-- => AnnKey
-- -> m ()
-- moveToExactAnn annKey = do
-- traceLocal ("moveToExactAnn", annKey)
-- anns <- mAsk
-- case Map.lookup annKey anns of
-- Nothing -> return ()
-- Just ann -> do
-- -- curY <- mGet <&> _lstate_curY
-- let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
-- -- mModify $ \state -> state { _lstate_addNewline = Just x }
-- moveToY y
moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state ->
let
upd = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in
state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
(lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
moveToCommentPos
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Bool
-> GHC.DeltaPos
-> m ()
moveToCommentPos absolute = \case
GHC.SameLine c -> layoutMoveToCommentPos absolute 0 c 1
GHC.DifferentLine l c -> layoutMoveToCommentPos absolute l c 1
-- moveToY :: MonadMultiState LayoutState m => Int -> m ()
-- moveToY y = mModify $ \state ->
-- let
-- upd = case _lstate_curYOrAddNewline state of
-- Left i -> if y == 0 then Left i else Right y
-- Right i -> Right $ max y i
-- in
-- state
-- { _lstate_curYOrAddNewline = upd
-- , _lstate_addSepSpace = if Data.Either.isRight upd
-- then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
-- (lstate_baseY state)
-- else Nothing
-- , _lstate_commentCol = Nothing
-- }
-- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do
@ -379,77 +396,71 @@ moveToY y = mModify $ \state ->
-- then x-1
-- else x
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " "
-- TODO: update and use, or clean up. Currently dead code.
layoutWritePriorComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Located ast
-> m ()
layoutWritePriorComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annPriorComments = [] })
key
anns
}
return mAnn
case mAnn of
Nothing -> return ()
Just priors -> do
unless (null priors) $ layoutSetCommentCol
priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
do
replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
-- layoutWritePriorComments
-- :: ( Data.Data.Data ast
-- , MonadMultiWriter Text.Builder.Builder m
-- , MonadMultiState LayoutState m
-- )
-- => Located ast
-- -> m ()
-- layoutWritePriorComments ast = do
-- mAnn <- do
-- state <- mGet
-- let key = ExactPrint.mkAnnKey ast
-- let anns = _lstate_comments state
-- let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
-- mSet $ state
-- { _lstate_comments = Map.adjust
-- (\ann -> ann { ExactPrint.annPriorComments = [] })
-- key
-- anns
-- }
-- return mAnn
-- case mAnn of
-- Nothing -> return ()
-- Just priors -> do
-- unless (null priors) $ layoutSetCommentCol
-- priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
-- do
-- replicateM_ x layoutWriteNewline
-- layoutWriteAppendSpaces y
-- layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
-- TODO: update and use, or clean up. Currently dead code.
-- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..".
layoutWritePostComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Located ast
-> m ()
layoutWritePostComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annFollowingComments = [] })
key
anns
}
return mAnn
case mAnn of
Nothing -> return ()
Just posts -> do
unless (null posts) $ layoutSetCommentCol
posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
do
replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' '
mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
-- layoutWritePostComments
-- :: ( Data.Data.Data ast
-- , MonadMultiWriter Text.Builder.Builder m
-- , MonadMultiState LayoutState m
-- )
-- => Located ast
-- -> m ()
-- layoutWritePostComments ast = do
-- mAnn <- do
-- state <- mGet
-- let key = ExactPrint.mkAnnKey ast
-- let anns = _lstate_comments state
-- let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
-- mSet $ state
-- { _lstate_comments = Map.adjust
-- (\ann -> ann { ExactPrint.annFollowingComments = [] })
-- key
-- anns
-- }
-- return mAnn
-- case mAnn of
-- Nothing -> return ()
-- Just posts -> do
-- unless (null posts) $ layoutSetCommentCol
-- posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
-- do
-- replicateM_ x layoutWriteNewline
-- layoutWriteAppend $ Text.pack $ replicate y ' '
-- mModify $ \s -> s { _lstate_addSepSpace = Nothing }
-- layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)

94
source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs Normal file
View File

@ -0,0 +1,94 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
module Language.Haskell.Brittany.Internal.WriteBriDoc.Types where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Safe
import GHC ( LEpaComment
)
import qualified Data.Text.Lazy.Builder as TextL.Builder
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
data LayoutState = LayoutState
{ _lstate_baseYs :: [Int]
-- ^ stack of number of current indentation columns
-- (not number of indentations).
, _lstate_curYOrAddNewline :: Either Int Int
-- ^ Either:
-- 1) number of chars in the current line.
-- 2) number of newlines to be inserted before inserting any
-- non-space elements.
, _lstate_indLevels :: [Int]
-- ^ stack of current indentation levels. set for
-- any layout-affected elements such as
-- let/do/case/where elements.
-- The main purpose of this member is to
-- properly align comments, as their
-- annotation positions are relative to the
-- current layout indentation level.
, _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for
-- properly treating cases where comments
-- on the first indented element have an
-- annotation offset relative to the last
-- non-indented element, which is confusing.
-- , _lstate_comments :: Anns
, _lstate_commentCol :: Maybe Int -- this communicates two things:
-- firstly, that cursor is currently
-- at the end of a comment (so needs
-- newline before any actual content).
-- secondly, the column at which
-- insertion of comments started.
, _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone
-- writes (any non-spaces) in the
-- current line.
-- , _lstate_isNewline :: NewLineState
-- -- captures if the layouter currently is in a new line, i.e. if the
-- -- current line only contains (indentation) spaces.
-- this is mostly superseeded by curYOrAddNewline, iirc.
, _lstate_commentNewlines :: Int -- number of newlines inserted due to
-- move-to-DP at a start of a comment.
-- Necessary because some keyword DPs
-- are relative to the last non-comment
-- entity (for some reason).
-- This is not very strictly reset to 0,
-- so we might in some cases get "artifacts"
-- from previous document elements.
-- But the worst effect at the moment would
-- be that we introduce less newlines on
-- moveToKWDP, which seems harmless enough.
}
lstate_baseY :: LayoutState -> Int
lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs
lstate_indLevel :: LayoutState -> Int
lstate_indLevel = Safe.headNote "lstate_indLevel" . _lstate_indLevels
-- evil, incomplete Show instance; only for debugging.
instance Show LayoutState where
show state =
"LayoutState"
++ "{baseYs=" ++ show (_lstate_baseYs state)
++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
++ ",indLevels=" ++ show (_lstate_indLevels state)
++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
++ ",commentCol=" ++ show (_lstate_commentCol state)
++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
++ ",commentNewlines=" ++ show (_lstate_commentNewlines state)
++ "}"
type LayoutConstraints m
= ( MonadMultiReader Config m
, MonadMultiWriter TextL.Builder.Builder m
, MonadMultiWriter (Seq String) m
, MonadMultiState LayoutState m
, MonadMultiState CommentCounter m
, MonadMultiState [GHC.LEpaComment] m
)

99
source/library/Language/Haskell/Brittany/Main.hs
View File

@ -10,22 +10,21 @@ import Data.CZipWith
import qualified Data.Either
import qualified Data.List.Extra
import qualified Data.Monoid
import qualified Data.Semigroup as Semigroup
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
import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Obfuscation
import Language.Haskell.Brittany.Internal.Components.Obfuscation
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
@ -60,6 +59,51 @@ main = do
args <- Environment.getArgs
mainWith progName args
testMain :: IO ()
testMain = do
h <- System.IO.openFile "local/sample-folder/err.txt" System.IO.WriteMode
let cmdlineR =
runCmdParser
Nothing
(InputArgs
[ "--output-on-errors"
, "--dump-ast-full"
, "--omit-output-check"
-- , "--dump-bridoc-alt"
, "--dump-bridoc-floating"
-- , "--dump-bridoc-par"
-- , "--dump-bridoc-columns"
, "--dump-bridoc-final"
]
)
$ do
reorderStart
c <- cmdlineConfigParser
reorderStop
addCmdImpl c
let cmdlineConfig = case _ppi_value cmdlineR of
Left err -> error (show err)
Right (Nothing) -> error "could not parse config"
Right (Just r ) -> r
configsToLoad <-
maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
config <- runMaybeT (readConfigs cmdlineConfig configsToLoad)
-- (readConfigsWithUserConfig cmdlineConfig configsToLoad)
>>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
Just x -> return x
System.IO.hPutStrLn h $ showConfigYaml config
e <- coreIO (System.IO.hPutStrLn h)
config
False
False
(Just "local/sample-folder/Test.hs")
(Just "local/sample-folder/out.txt")
case e of
Left i -> print i
Right Changes -> putStrLn "Changes"
Right NoChanges -> putStrLn "NoChanges"
mainWith :: String -> [String] -> IO ()
mainWith progName args =
Environment.withProgName progName
@ -246,7 +290,6 @@ mainCmdParser = do
[Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)
_ -> System.Exit.exitWith (System.Exit.ExitFailure 1)
data ChangeStatus = Changes | NoChanges
deriving (Eq)
@ -337,11 +380,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
putErrorLn "parse error:"
putErrorLn left
ExceptT.throwE 60
Right (anns, parsedSource, hasCPP) -> do
(inlineConf, perItemConf) <-
case
extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
of
Right (parsedSource, hasCPP) -> do
(inlineConf, perItemConf) <- do
resE <-
liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource
case resE of
Left (err, input) -> do
putErrorLn $ "Error: parse error in inline configuration:"
putErrorLn err
@ -351,8 +394,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
pure c
let moduleConf = cZipWith fromOptionIdentity config inlineConf
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return ()
let val = printTreeWithCustom 160 customLayouterF parsedSource
putErrorLn ("---- ast ----\n" ++ show val)
let
disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack
@ -361,7 +404,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
| disableFormatting -> do
pure ([], originalContents, False)
| exactprintOnly -> do
let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
let r = Text.pack $ ExactPrint.exactPrint parsedSource
pure ([], r, r /= originalContents)
| otherwise -> do
let
@ -371,13 +414,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
.> _econf_omit_output_valid_check
.> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then return
$ pPrintModule moduleConf perItemConf anns parsedSource
else liftIO $ pPrintModuleAndCheck
moduleConf
perItemConf
anns
parsedSource
then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
else liftIO
$ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
let
hackF s = fromMaybe s $ TextL.stripPrefix
(TextL.pack "-- BRITANY_INCLUDE_HACK ")
@ -398,6 +437,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnusedComments{} = 3
customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do
@ -445,6 +485,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
unused `forM_` \case
ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)"
unused@(ErrorUnusedComments{} : _) -> do
unused `forM_` \case
ErrorUnusedComments (L (GHC.SrcSpanAnn _ ann) _) cIn cOut -> do
putErrorLn
$ "Error: detected unprocessed comments ("
++ show cOut ++ " out of " ++ show cIn ++ ")."
++ " The transformation output will most likely"
++ " not contain some of the comments"
++ " present in the input haskell source file."
putErrorLn $ "Affected is the declaration at " ++ show (astToDoc ann)
_ -> error "cannot happen (TM)"
(ErrorMacroConfig err input : _) -> do
putErrorLn $ "Error: parse error in inline configuration:"
putErrorLn err
@ -473,10 +524,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do
let
isIdentical = case inputPathM of
Nothing -> False
Just _ -> not hasChanges
unless isIdentical $ Text.IO.writeFile p $ outSText
shouldWrite = case inputPathM of
Nothing -> True
Just p2 -> hasChanges || p /= p2
when shouldWrite $ Text.IO.writeFile p $ outSText
when (checkMode && hasChanges) $ case inputPathM of
Nothing -> pure ()

3
source/test-suite/Main.hs
View File

@ -12,10 +12,9 @@ import qualified GHC.OldList as List
import qualified Data.Map.Strict as Map
import Data.These
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified System.Directory
import System.FilePath ((</>))
import System.Timeout (timeout)