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

Format Brittany with Brittany

pull/357/head
Taylor Fausak 2021-11-06 22:29:34 +00:00 committed by GitHub
parent ac81c5ce90
commit 4398b5880d
33 changed files with 4688 additions and 4799 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
brittany.yaml Normal file
View File

@ -0,0 +1,5 @@
conf_layout:
lconfig_cols: 79
lconfig_columnAlignMode:
tag: ColumnAlignModeDisabled
lconfig_indentPolicy: IndentPolicyLeft

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

@ -16,13 +16,9 @@ module Language.Haskell.Brittany
, CForwardOptions(..) , CForwardOptions(..)
, CPreProcessorConfig(..) , CPreProcessorConfig(..)
, BrittanyError(..) , BrittanyError(..)
) ) where
where
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config

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

@ -12,68 +12,52 @@ module Language.Haskell.Brittany.Internal
, parseModuleFromString , parseModuleFromString
, extractCommentConfigs , extractCommentConfigs
, getTopLevelDeclNameMap , getTopLevelDeclNameMap
) ) where
where
import Control.Monad.Trans.Except
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.ByteString.Char8 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.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import qualified GHC.OldList as List import qualified Data.Text.Lazy.Builder as Text.Builder
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import Control.Monad.Trans.Except
import Data.HList.HList
import qualified Data.Yaml import qualified Data.Yaml
import Data.CZipWith import qualified GHC hiding (parseModule)
import qualified UI.Butcher.Monadic as Butcher import GHC (GenLocated(L))
import GHC.Data.Bag
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.Driver.Session as GHC
import GHC.Hs
import Language.Haskell.Brittany.Internal.Types import qualified GHC.LanguageExtensions.Type as GHC
import Language.Haskell.Brittany.Internal.Config.Types import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config import GHC.Parser.Annotation (AnnKeywordId(..))
import Language.Haskell.Brittany.Internal.LayouterBasics import GHC.Types.SrcLoc (SrcSpan)
import Language.Haskell.Brittany.Internal.Backend
import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Layouters.Module import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.BackendUtils import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Transformations.Alt import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Transformations.Floating import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Transformations.Par import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Indent import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC import Language.Haskell.Brittany.Internal.Transformations.Par
hiding ( parseModule ) import Language.Haskell.Brittany.Internal.Types
import GHC.Parser.Annotation ( AnnKeywordId(..) ) import Language.Haskell.Brittany.Internal.Utils
import GHC ( GenLocated(L) import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
) import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import GHC.Types.SrcLoc ( SrcSpan ) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import GHC.Hs import qualified UI.Butcher.Monadic as Butcher
import GHC.Data.Bag
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Data.Char ( isSpace )
data InlineConfigTarget data InlineConfigTarget
= InlineConfigTargetModule = InlineConfigTargetModule
@ -91,35 +75,36 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
[ ( k [ ( k
, [ x , [ x
| (ExactPrint.Comment x _ _, _) <- | (ExactPrint.Comment x _ _, _) <-
( ExactPrint.annPriorComments ann (ExactPrint.annPriorComments ann
++ ExactPrint.annFollowingComments ann ++ ExactPrint.annFollowingComments ann
) )
] ]
++ [ x ++ [ x
| (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
ExactPrint.annsDP ann ExactPrint.annsDP ann
] ]
) )
| (k, ann) <- Map.toList anns | (k, ann) <- Map.toList anns
] ]
let configLiness = commentLiness <&> second let
(Data.Maybe.mapMaybe $ \line -> do configLiness = commentLiness <&> second
l1 <- (Data.Maybe.mapMaybe $ \line -> do
List.stripPrefix "-- BRITTANY" line l1 <-
<|> List.stripPrefix "--BRITTANY" line List.stripPrefix "-- BRITTANY" line
<|> List.stripPrefix "-- brittany" line <|> List.stripPrefix "--BRITTANY" line
<|> List.stripPrefix "--brittany" line <|> List.stripPrefix "-- brittany" line
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") <|> List.stripPrefix "--brittany" line
let l2 = dropWhile isSpace l1 <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
guard let l2 = dropWhile isSpace l1
( ("@" `isPrefixOf` l2) guard
|| ("-disable" `isPrefixOf` l2) (("@" `isPrefixOf` l2)
|| ("-next" `isPrefixOf` l2) || ("-disable" `isPrefixOf` l2)
|| ("{" `isPrefixOf` l2) || ("-next" `isPrefixOf` l2)
|| ("--" `isPrefixOf` l2) || ("{" `isPrefixOf` l2)
) || ("--" `isPrefixOf` l2)
pure l2 )
) pure l2
)
let let
configParser = Butcher.addAlternatives configParser = Butcher.addAlternatives
[ ( "commandline-config" [ ( "commandline-config"
@ -138,39 +123,44 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
] ]
parser = do -- we will (mis?)use butcher here to parse the inline config parser = do -- we will (mis?)use butcher here to parse the inline config
-- line. -- line.
let nextDecl = do let
conf <- configParser nextDecl = do
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-next-declaration" nextDecl
Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl
Butcher.addCmd "-NEXT-DECLARATION" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl
let nextBinding = do let
conf <- configParser nextBinding = do
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-next-binding" nextBinding
Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding
Butcher.addCmd "-NEXT-BINDING" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding
let disableNextBinding = do let
Butcher.addCmdImpl disableNextBinding = do
( InlineConfigTargetNextBinding Butcher.addCmdImpl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } ( 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 Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
let disableNextDecl = do let
Butcher.addCmdImpl disableNextDecl = do
( InlineConfigTargetNextDecl Butcher.addCmdImpl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } ( 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 Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
let disableFormatting = do let
Butcher.addCmdImpl disableFormatting = do
( InlineConfigTargetModule Butcher.addCmdImpl
, mempty { _conf_disable_formatting = pure $ pure True } ( InlineConfigTargetModule
) , mempty { _conf_disable_formatting = pure $ pure True }
)
Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "-disable" disableFormatting
Butcher.addCmd "@" $ do Butcher.addCmd "@" $ do
-- Butcher.addCmd "module" $ do -- Butcher.addCmd "module" $ do
@ -178,41 +168,42 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
-- Butcher.addCmdImpl (InlineConfigTargetModule, conf) -- Butcher.addCmdImpl (InlineConfigTargetModule, conf)
Butcher.addNullCmd $ do Butcher.addNullCmd $ do
bindingName <- Butcher.addParamString "BINDING" mempty bindingName <- Butcher.addParamString "BINDING" mempty
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetModule, conf) Butcher.addCmdImpl (InlineConfigTargetModule, conf)
lineConfigss <- configLiness `forM` \(k, ss) -> do lineConfigss <- configLiness `forM` \(k, ss) -> do
r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of
Left err -> Left $ (err, s) Left err -> Left $ (err, s)
Right c -> Right $ c Right c -> Right $ c
pure (k, r) pure (k, r)
let perModule = foldl' let
(<>) perModule = foldl'
mempty (<>)
[ conf mempty
| (_ , lineConfigs) <- lineConfigss [ conf
, (InlineConfigTargetModule, conf ) <- lineConfigs | (_, lineConfigs) <- lineConfigss
] , (InlineConfigTargetModule, conf) <- lineConfigs
]
let let
perBinding = Map.fromListWith perBinding = Map.fromListWith
(<>) (<>)
[ (n, conf) [ (n, conf)
| (k , lineConfigs) <- lineConfigss | (k, lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs , (target, conf) <- lineConfigs
, n <- case target of , n <- case target of
InlineConfigTargetBinding s -> [s] InlineConfigTargetBinding s -> [s]
InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> InlineConfigTargetNextBinding
[name] | Just name <- Map.lookup k declNameMap -> [name]
_ -> [] _ -> []
] ]
let let
perKey = Map.fromListWith perKey = Map.fromListWith
(<>) (<>)
[ (k, conf) [ (k, conf)
| (k , lineConfigs) <- lineConfigss | (k, lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs , (target, conf) <- lineConfigs
, case target of , case target of
InlineConfigTargetNextDecl -> True InlineConfigTargetNextDecl -> True
InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->
@ -230,7 +221,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
TopLevelDeclNameMap $ Map.fromList TopLevelDeclNameMap $ Map.fromList
[ (ExactPrint.mkAnnKey decl, name) [ (ExactPrint.mkAnnKey decl, name)
| decl <- decls | decl <- decls
, (name : _) <- [getDeclBindingNames decl] , (name : _) <- [getDeclBindingNames decl]
] ]
@ -248,70 +239,78 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
-- won't do. -- won't do.
parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule configWithDebugs inputText = runExceptT $ do parsePrintModule configWithDebugs inputText = runExceptT $ do
let config = let
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } config =
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let config_pp = config & _conf_preprocessor let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let cppMode = config_pp & _ppconf_CPPMode & confUnpack let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
(anns, parsedSource, hasCPP) <- do (anns, parsedSource, hasCPP) <- do
let hackF s = if "#include" `isPrefixOf` s let
then "-- BRITANY_INCLUDE_HACK " ++ s hackF s = if "#include" `isPrefixOf` s
else s then "-- BRITANY_INCLUDE_HACK " ++ s
let hackTransform = if hackAroundIncludes else s
then List.intercalate "\n" . fmap hackF . lines' let
else id hackTransform = if hackAroundIncludes
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags then List.intercalate "\n" . fmap hackF . lines'
then case cppMode of else id
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." let
CPPModeWarn -> return $ Right True cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
CPPModeNowarn -> return $ Right True then case cppMode of
else return $ Right False CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
parseResult <- lift $ parseModuleFromString parseResult <- lift $ parseModuleFromString
ghcOptions ghcOptions
"stdin" "stdin"
cppCheckFunc cppCheckFunc
(hackTransform $ Text.unpack inputText) (hackTransform $ Text.unpack inputText)
case parseResult of case parseResult of
Left err -> throwE [ErrorInput err] Left err -> throwE [ErrorInput err]
Right x -> pure x Right x -> pure x
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
either (throwE . (: []) . uncurry ErrorMacroConfig) pure either (throwE . (: []) . uncurry ErrorMacroConfig) pure
$ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
let moduleConfig = cZipWith fromOptionIdentity config inlineConf let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
if disableFormatting if disableFormatting
then do then do
return inputText return inputText
else do else do
(errsWarns, outputTextL) <- do (errsWarns, outputTextL) <- do
let omitCheck = let
moduleConfig omitCheck =
& _conf_errorHandling moduleConfig
& _econf_omit_output_valid_check & _conf_errorHandling
& confUnpack & _econf_omit_output_valid_check
& confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConfig perItemConf anns parsedSource then return $ pPrintModule moduleConfig perItemConf anns parsedSource
else lift else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
let hackF s = fromMaybe s let
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
then then
( ews ( ews
, TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn , TextL.intercalate (TextL.pack "\n")
(TextL.pack "\n") $ hackF
outRaw <$> TextL.splitOn (TextL.pack "\n") outRaw
) )
else (ews, outRaw) else (ews, outRaw)
let customErrOrder ErrorInput{} = 4 let
customErrOrder LayoutWarning{} = 0 :: Int customErrOrder ErrorInput{} = 4
customErrOrder ErrorOutputCheck{} = 1 customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorUnknownNode{} = 3
let hasErrors = customErrOrder ErrorMacroConfig{} = 5
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack let
hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns) else 0 < maximum (-1 : fmap customErrOrder errsWarns)
if hasErrors if hasErrors
@ -331,26 +330,27 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([BrittanyError], TextL.Text) -> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule = pPrintModule conf inlineConf anns parsedModule =
let ((out, errs), debugStrings) = let
runIdentity ((out, errs), debugStrings) =
$ MultiRWSS.runMultiRWSTNil runIdentity
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiReader conf $ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader inlineConf $ MultiRWSS.withMultiReader conf
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ MultiRWSS.withMultiReader inlineConf
$ do $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ do
$ annsDoc anns traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
ppModule parsedModule $ annsDoc anns
tracer = if Seq.null debugStrings ppModule parsedModule
then id tracer = if Seq.null debugStrings
else then id
trace ("---- DEBUGMESSAGES ---- ") else
. foldr (seq . join trace) id debugStrings trace ("---- DEBUGMESSAGES ---- ")
in tracer $ (errs, Text.Builder.toLazyText out) . foldr (seq . join trace) id debugStrings
in tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do -- unless () $ do
-- --
-- debugStrings `forM_` \s -> -- debugStrings `forM_` \s ->
@ -365,15 +365,17 @@ pPrintModuleAndCheck
-> GHC.ParsedSource -> GHC.ParsedSource
-> IO ([BrittanyError], TextL.Text) -> IO ([BrittanyError], TextL.Text)
pPrintModuleAndCheck conf inlineConf anns parsedModule = do pPrintModuleAndCheck conf inlineConf anns parsedModule = do
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
let (errs, output) = pPrintModule conf inlineConf anns parsedModule let (errs, output) = pPrintModule conf inlineConf anns parsedModule
parseResult <- parseModuleFromString ghcOptions parseResult <- parseModuleFromString
"output" ghcOptions
(\_ -> return $ Right ()) "output"
(TextL.unpack output) (\_ -> return $ Right ())
let errs' = errs ++ case parseResult of (TextL.unpack output)
Left{} -> [ErrorOutputCheck] let
Right{} -> [] errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck]
Right{} -> []
return (errs', output) return (errs', output)
@ -384,18 +386,22 @@ parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
case parseResult of case parseResult of
Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) Left err ->
return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
Right (anns, parsedModule) -> runExceptT $ do Right (anns, parsedModule) -> runExceptT $ do
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of case
Left err -> throwE $ "error in inline config: " ++ show err extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule)
Right x -> pure x of
Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x
let moduleConf = cZipWith fromOptionIdentity conf inlineConf let moduleConf = cZipWith fromOptionIdentity conf inlineConf
let omitCheck = let
conf omitCheck =
& _conf_errorHandling conf
.> _econf_omit_output_valid_check & _conf_errorHandling
.> confUnpack .> _econf_omit_output_valid_check
.> confUnpack
(errs, ltext) <- if omitCheck (errs, ltext) <- if omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedModule then return $ pPrintModule moduleConf perItemConf anns parsedModule
else lift else lift
@ -405,13 +411,13 @@ parsePrintModuleTests conf filename input = do
else else
let let
errStrs = errs <&> \case errStrs = errs <&> \case
ErrorInput str -> str ErrorInput str -> str
ErrorUnusedComment str -> str ErrorUnusedComment str -> str
LayoutWarning str -> str LayoutWarning str -> str
ErrorUnknownNode str _ -> str ErrorUnknownNode str _ -> str
ErrorMacroConfig str _ -> "when parsing inline config: " ++ str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
ErrorOutputCheck -> "Output is not syntactically valid." ErrorOutputCheck -> "Output is not syntactically valid."
in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs
isErrorUnusedComment :: BrittanyError -> Bool isErrorUnusedComment :: BrittanyError -> Bool
isErrorUnusedComment x = case x of isErrorUnusedComment x = case x of
@ -464,27 +470,30 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
let annKey = ExactPrint.mkAnnKey lmod let annKey = ExactPrint.mkAnnKey lmod
post <- ppPreamble lmod post <- ppPreamble lmod
decls `forM_` \decl -> do decls `forM_` \decl -> do
let declAnnKey = ExactPrint.mkAnnKey decl let declAnnKey = ExactPrint.mkAnnKey decl
let declBindingNames = getDeclBindingNames decl let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
let mBindingConfs = let
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf mBindingConfs =
filteredAnns <- mAsk declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
<&> \annMap -> filteredAnns <- mAsk <&> \annMap ->
Map.union (Map.findWithDefault Map.empty annKey annMap) $ Map.union (Map.findWithDefault Map.empty annKey annMap)
Map.findWithDefault Map.empty declAnnKey annMap $ Map.findWithDefault Map.empty declAnnKey annMap
traceIfDumpConf "bridoc annotations filtered/transformed" traceIfDumpConf
_dconf_dump_annotations "bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns $ annsDoc filteredAnns
config <- mAsk config <- mAsk
let config' = cZipWith fromOptionIdentity config let
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack let
exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do toLocal config' filteredAnns $ do
bd <- if exactprintOnly bd <- if exactprintOnly
then briDocMToPPM $ briDocByExactNoComment decl then briDocMToPPM $ briDocByExactNoComment decl
@ -497,33 +506,34 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd layoutBriDoc bd
let finalComments = filter let
(fst .> \case finalComments = filter
ExactPrint.AnnComment{} -> True (fst .> \case
_ -> False ExactPrint.AnnComment{} -> True
) _ -> False
post )
post
post `forM_` \case post `forM_` \case
(ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
ppmMoveToExactLoc l ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr mTell $ Text.Builder.fromString cmStr
(ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of let
ExactPrint.AnnComment cm folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
| span <- ExactPrint.commentIdentifier cm ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
-> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
) )
_ -> (acc + y, x) _ -> (acc + y, x)
(cmY, cmX) = foldl' folder (0, 0) finalComments (cmY, cmX) = foldl' folder (0, 0) finalComments
in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
_ -> return () _ -> return ()
getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames :: LHsDecl GhcPs -> [String]
getDeclBindingNames (L _ decl) = case decl of getDeclBindingNames (L _ decl) = case decl of
SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
_ -> [] _ -> []
-- Prints the information associated with the module annotation -- Prints the information associated with the module annotation
@ -540,8 +550,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
-- attached annotations that come after the module's where -- attached annotations that come after the module's where
-- from the module node -- from the module node
config <- mAsk config <- mAsk
let shouldReformatPreamble = let
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let let
(filteredAnns', post) = (filteredAnns', post) =
@ -551,23 +562,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
let let
modAnnsDp = ExactPrint.annsDP mAnn modAnnsDp = ExactPrint.annsDP mAnn
isWhere (ExactPrint.G AnnWhere) = True isWhere (ExactPrint.G AnnWhere) = True
isWhere _ = False isWhere _ = False
isEof (ExactPrint.AnnEofPos) = True isEof (ExactPrint.AnnEofPos) = True
isEof _ = False isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp
(pre, post') = case (whereInd, eofInd) of (pre, post') = case (whereInd, eofInd) of
(Nothing, Nothing) -> ([], modAnnsDp) (Nothing, Nothing) -> ([], modAnnsDp)
(Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp) (Nothing, Just _i) -> ([], modAnnsDp)
(Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp
mAnn' = mAnn { ExactPrint.annsDP = pre } mAnn' = mAnn { ExactPrint.annsDP = pre }
filteredAnns'' = filteredAnns'' =
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
in in (filteredAnns'', post')
(filteredAnns'', post') traceIfDumpConf
traceIfDumpConf "bridoc annotations filtered/transformed" "bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns' $ annsDoc filteredAnns'
if shouldReformatPreamble if shouldReformatPreamble
@ -576,7 +587,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
layoutBriDoc briDoc layoutBriDoc briDoc
else else
let emptyModule = L loc m { hsmodDecls = [] } let emptyModule = L loc m { hsmodDecls = [] }
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
return post return post
_sigHead :: Sig GhcPs -> String _sigHead :: Sig GhcPs -> String
@ -589,7 +600,7 @@ _bindHead :: HsBind GhcPs -> String
_bindHead = \case _bindHead = \case
FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth" PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind" _ -> "unknown bind"
@ -607,63 +618,67 @@ layoutBriDoc briDoc = do
transformAlts briDoc >>= mSet transformAlts briDoc >>= mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet >>= transformSimplifyFloating .> mSet mGet >>= transformSimplifyFloating .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-floating" .> traceIfDumpConf
_dconf_dump_bridoc_simpl_floating "bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
-- bridoc transformation: par removal -- bridoc transformation: par removal
mGet >>= transformSimplifyPar .> mSet mGet >>= transformSimplifyPar .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet >>= transformSimplifyColumns .> mSet mGet >>= transformSimplifyColumns .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
-- bridoc transformation: indent -- bridoc transformation: indent
mGet >>= transformSimplifyIndent .> mSet mGet >>= transformSimplifyIndent .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
-- -- convert to Simple type -- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple -- simpl <- mGet <&> transformToSimple
-- return simpl -- return simpl
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
let state = LayoutState { _lstate_baseYs = [0] let
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left state = LayoutState
-- here because moveToAnn stuff { _lstate_baseYs = [0]
-- of the first node needs to do , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-- its thing properly. -- here because moveToAnn stuff
, _lstate_indLevels = [0] -- of the first node needs to do
, _lstate_indLevelLinger = 0 -- its thing properly.
, _lstate_comments = anns , _lstate_indLevels = [0]
, _lstate_commentCol = Nothing , _lstate_indLevelLinger = 0
, _lstate_addSepSpace = Nothing , _lstate_comments = anns
, _lstate_commentNewlines = 0 , _lstate_commentCol = Nothing
} , _lstate_addSepSpace = Nothing
, _lstate_commentNewlines = 0
}
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let remainingComments = let
[ c remainingComments =
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList [ c
(_lstate_comments state') | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
-- With the new import layouter, we manually process comments (_lstate_comments state')
-- without relying on the backend to consume the comments out of -- With the new import layouter, we manually process comments
-- the state/map. So they will end up here, and we need to ignore -- without relying on the backend to consume the comments out of
-- them. -- the state/map. So they will end up here, and we need to ignore
, ExactPrint.unConName con /= "ImportDecl" -- them.
, c <- extractAllComments elemAnns , ExactPrint.unConName con /= "ImportDecl"
] , c <- extractAllComments elemAnns
]
remainingComments remainingComments
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)

540
source/library/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -6,10 +6,6 @@
module Language.Haskell.Brittany.Internal.Backend where module Language.Haskell.Brittany.Internal.Backend where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.State.Strict as StateS import qualified Control.Monad.Trans.State.Strict as StateS
import qualified Data.Either as Either import qualified Data.Either as Either
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
@ -21,32 +17,32 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List 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 as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.Brittany.Internal.LayouterBasics type ColIndex = Int
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
type ColIndex = Int
data ColumnSpacing data ColumnSpacing
= ColumnSpacingLeaf Int = ColumnSpacingLeaf Int
| ColumnSpacingRef Int Int | ColumnSpacingRef Int Int
type ColumnBlock a = [a] type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a] type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) type ColMap1
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) = IntMapL.IntMap {- ColIndex -}
(Bool, ColumnBlocks ColumnSpacing)
type ColMap2
= IntMapL.IntMap {- ColIndex -}
(Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw) -- (ratio of hasSpace, maximum, raw)
data ColInfo data ColInfo
@ -56,20 +52,23 @@ data ColInfo
instance Show ColInfo where instance Show ColInfo where
show ColInfoStart = "ColInfoStart" show ColInfoStart = "ColInfoStart"
show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") show (ColInfoNo bd) =
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
show (ColInfo ind sig list) =
"ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1 { _cbs_map :: ColMap1
, _cbs_index :: ColIndex , _cbs_index :: ColIndex
} }
type LayoutConstraints m = ( MonadMultiReader Config m type LayoutConstraints m
, MonadMultiReader ExactPrint.Types.Anns m = ( MonadMultiReader Config m
, MonadMultiWriter Text.Builder.Builder m , MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter (Seq String) m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m
) , MonadMultiState LayoutState m
)
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case layoutBriDocM = \case
@ -90,10 +89,11 @@ layoutBriDocM = \case
BDSeparator -> do BDSeparator -> do
layoutAddSepSpace layoutAddSepSpace
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
let indentF = case indent of let
BrIndentNone -> id indentF = case indent of
BrIndentRegular -> layoutWithAddBaseCol BrIndentNone -> id
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
layoutBaseYPushCur layoutBaseYPushCur
@ -108,36 +108,39 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
layoutIndentLevelPop layoutIndentLevelPop
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
let indentF = case indent of let
BrIndentNone -> id indentF = case indent of
BrIndentRegular -> layoutWithAddBaseCol BrIndentNone -> id
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do indentF $ do
layoutWriteEnsureBlock layoutWriteEnsureBlock
layoutBriDocM bd layoutBriDocM bd
BDPar indent sameLine indented -> do BDPar indent sameLine indented -> do
layoutBriDocM sameLine layoutBriDocM sameLine
let indentF = case indent of let
BrIndentNone -> id indentF = case indent of
BrIndentRegular -> layoutWithAddBaseCol BrIndentNone -> id
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do indentF $ do
layoutWriteNewlineBlock layoutWriteNewlineBlock
layoutBriDocM indented layoutBriDocM indented
BDLines lines -> alignColsLines lines BDLines lines -> alignColsLines lines
BDAlt [] -> error "empty BDAlt" BDAlt [] -> error "empty BDAlt"
BDAlt (alt:_) -> layoutBriDocM alt BDAlt (alt : _) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do BDExternal annKey subKeys shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n" let
tlineCount = length tlines tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do when shouldAddComment $ do
layoutWriteAppend layoutWriteAppend
$ Text.pack $ Text.pack
$ "{-" $ "{-"
++ show (annKey, Map.lookup annKey anns) ++ show (annKey, Map.lookup annKey anns)
++ "-}" ++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do zip [1 ..] tlines `forM_` \(i, l) -> do
@ -154,9 +157,10 @@ layoutBriDocM = \case
BDAnnotationPrior annKey bd -> do BDAnnotationPrior annKey bd -> do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let moveToExactLocationAction = case _lstate_curYOrAddNewline state of let
Left{} -> pure () moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Right{} -> moveToExactAnn annKey Left{} -> pure ()
Right{} -> moveToExactAnn annKey
mAnn <- do mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
mSet $ state mSet $ state
@ -167,8 +171,8 @@ layoutBriDocM = \case
} }
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> moveToExactLocationAction Nothing -> moveToExactLocationAction
Just [] -> moveToExactLocationAction Just [] -> moveToExactLocationAction
Just priors -> do Just priors -> do
-- layoutResetSepSpace -- layoutResetSepSpace
priors priors
@ -176,9 +180,10 @@ layoutBriDocM = \case
when (comment /= "(" && comment /= ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment let commentLines = Text.lines $ Text.pack $ comment
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) ('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
-- ^ evil hack for CPP -- ^ evil hack for CPP
_ -> layoutMoveToCommentPos y x (length commentLines) _ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y -- layoutMoveToIndentCol y
@ -190,18 +195,20 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
mComments <- do mComments <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of let
Just anns | Maybe.isNothing keyword -> Just anns mToSpan = case mAnn of
Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just Just anns | Maybe.isNothing keyword -> Just anns
annR Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
_ -> Nothing Just annR
_ -> Nothing
case mToSpan of case mToSpan of
Just anns -> do Just anns -> do
let (comments, rest) = flip spanMaybe anns $ \case let
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) (comments, rest) = flip spanMaybe anns $ \case
_ -> Nothing (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state mSet $ state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annsDP = rest }) (\ann -> ann { ExactPrint.annsDP = rest })
@ -213,17 +220,19 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> pure () Nothing -> pure ()
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments
when (comment /= "(" && comment /= ")") $ do `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
let commentLines = Text.lines $ Text.pack $ comment when (comment /= "(" && comment /= ")") $ do
-- evil hack for CPP: let commentLines = Text.lines $ Text.pack $ comment
case comment of -- evil hack for CPP:
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) case comment of
_ -> layoutMoveToCommentPos y x (length commentLines) ('#' : _) ->
-- fixedX <- fixMoveToLineByIsNewline x layoutMoveToCommentPos y (-999) (length commentLines)
-- replicateM_ fixedX layoutWriteNewline _ -> layoutMoveToCommentPos y x (length commentLines)
-- layoutMoveToIndentCol y -- fixedX <- fixMoveToLineByIsNewline x
layoutWriteAppendMultiline commentLines -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do BDAnnotationRest annKey bd -> do
layoutBriDocM bd layoutBriDocM bd
@ -232,21 +241,26 @@ layoutBriDocM = \case
let m = _lstate_comments state let m = _lstate_comments state
pure $ Map.lookup annKey m pure $ Map.lookup annKey m
let mComments = nonEmpty . extractAllComments =<< annMay let mComments = nonEmpty . extractAllComments =<< annMay
let semiCount = length [ () let
| Just ann <- [ annMay ] semiCount = length
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann [ ()
] | Just ann <- [annMay]
shouldAddSemicolonNewlines <- mAsk <&> , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
_conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack ]
shouldAddSemicolonNewlines <-
mAsk
<&> _conf_layout
.> _lconfig_experimentalSemicolonNewlines
.> confUnpack
mModify $ \state -> state mModify $ \state -> state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
( \ann -> ann { ExactPrint.annFollowingComments = [] (\ann -> ann
, ExactPrint.annPriorComments = [] { ExactPrint.annFollowingComments = []
, ExactPrint.annsDP = , ExactPrint.annPriorComments = []
flip filter (ExactPrint.annsDP ann) $ \case , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False (ExactPrint.Types.AnnComment{}, _) -> False
_ -> True _ -> True
} }
) )
annKey annKey
(_lstate_comments state) (_lstate_comments state)
@ -254,37 +268,40 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> do Nothing -> do
when shouldAddSemicolonNewlines $ do when shouldAddSemicolonNewlines $ do
[1..semiCount] `forM_` const layoutWriteNewline [1 .. semiCount] `forM_` const layoutWriteNewline
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments
when (comment /= "(" && comment /= ")") $ do `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
let commentLines = Text.lines $ Text.pack comment when (comment /= "(" && comment /= ")") $ do
case comment of let commentLines = Text.lines $ Text.pack comment
('#':_) -> layoutMoveToCommentPos y (-999) 1 case comment of
-- ^ evil hack for CPP ('#' : _) -> layoutMoveToCommentPos y (-999) 1
")" -> pure () -- ^ evil hack for CPP
-- ^ fixes the formatting of parens ")" -> pure ()
-- on the lhs of type alias defs -- ^ fixes the formatting of parens
_ -> layoutMoveToCommentPos y x (length commentLines) -- on the lhs of type alias defs
-- fixedX <- fixMoveToLineByIsNewline x _ -> layoutMoveToCommentPos y x (length commentLines)
-- replicateM_ fixedX layoutWriteNewline -- fixedX <- fixMoveToLineByIsNewline x
-- layoutMoveToIndentCol y -- replicateM_ fixedX layoutWriteNewline
layoutWriteAppendMultiline commentLines -- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
mDP <- do mDP <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let relevant = [ dp let
| Just ann <- [mAnn] relevant =
, (ExactPrint.Types.G kw1, dp) <- ann [ dp
, keyword == kw1 | Just ann <- [mAnn]
] , (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1
]
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
case relevant of case relevant of
[] -> pure Nothing [] -> pure Nothing
(ExactPrint.Types.DP (y, x):_) -> do (ExactPrint.Types.DP (y, x) : _) -> do
mSet state { _lstate_commentNewlines = 0 } mSet state { _lstate_commentNewlines = 0 }
pure $ Just (y - _lstate_commentNewlines state, x) pure $ Just (y - _lstate_commentNewlines state, x)
case mDP of case mDP of
@ -295,8 +312,8 @@ layoutBriDocM = \case
layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1
layoutBriDocM bd layoutBriDocM bd
BDNonBottomSpacing _ bd -> layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd
BDDebug s bd -> do BDDebug s bd -> do
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd layoutBriDocM bd
@ -307,73 +324,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- appended at the current position. -- appended at the current position.
where where
rec = \case rec = \case
BDEmpty -> return $ 0 BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt" BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t BDExternal _ _ _ t -> return $ Text.length t
BDPlain t -> return $ Text.length t BDPlain t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd
BDLines ls@(_ : _) -> do BDLines ls@(_ : _) -> do
x <- StateS.get x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []" BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc briDocIsMultiLine briDoc = rec briDoc
where where
rec :: BriDoc -> Bool rec :: BriDoc -> Bool
rec = \case rec = \case
BDEmpty -> False BDEmpty -> False
BDLit _ -> False BDLit _ -> False
BDSeq bds -> any rec bds BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds BDCols _ bds -> any rec bds
BDSeparator -> False BDSeparator -> False
BDAddBaseY _ bd -> rec bd BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar{} -> True BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt" BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t | [_] <- Text.lines t -> False BDExternal _ _ _ t | [_] <- Text.lines t -> False
BDExternal{} -> True BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True BDPlain _ -> True
BDAnnotationPrior _ bd -> rec bd BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd
BDLines (_ : _ : _) -> True BDLines (_ : _ : _) -> True
BDLines [_ ] -> False BDLines [_] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []" BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
-- In theory -- In theory
-- ========= -- =========
@ -458,16 +475,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe
0 0
(_lstate_addSepSpace state) (_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
alignBreak <- alignBreak <-
mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
case () of case () of
_ -> do _ -> do
-- tellDebugMess ("processedMap: " ++ show processedMap) -- tellDebugMess ("processedMap: " ++ show processedMap)
sequence_ sequence_
$ List.intersperse layoutWriteEnsureNewlineBlock $ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos $ colInfos
<&> processInfo colMax processedMap <&> processInfo colMax processedMap
where where
(colInfos, finalState) = (colInfos, finalState) =
@ -484,40 +501,41 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
where alignMax' = max 0 alignMax where alignMax' = max 0 alignMax
processedMap :: ColMap2 processedMap :: ColMap2
processedMap = processedMap = fix $ \result ->
fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let let
colss = colSpacingss <&> \spss -> case reverse spss of colss = colSpacingss <&> \spss -> case reverse spss of
[] -> [] [] -> []
(xN:xR) -> (xN : xR) ->
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR reverse
$ (if lastFlag then fLast else fInit) xN
: fmap fInit xR
where where
fLast (ColumnSpacingLeaf len ) = len fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0 Nothing -> 0
Just (_, maxs, _) -> sum maxs Just (_, maxs, _) -> sum maxs
maxCols = {-Foldable.foldl1 maxZipper-} maxCols = {-Foldable.foldl1 maxZipper-}
fmap colAggregation $ transpose $ Foldable.toList colss fmap colAggregation $ transpose $ Foldable.toList colss
(_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $
mapAccumL (\acc x -> (acc + x, acc)) curX maxCols mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
counter count l = if List.last posXs + List.last l <= colMax counter count l = if List.last posXs + List.last l <= colMax
then count + 1 then count + 1
else count else count
ratio = fromIntegral (foldl counter (0 :: Int) colss) ratio = fromIntegral (foldl counter (0 :: Int) colss)
/ fromIntegral (length colss) / fromIntegral (length colss)
in in (ratio, maxCols, colss)
(ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW mergeBriDocsW
:: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return [] mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do mergeBriDocsW lastInfo (bd : bdr) = do
info <- mergeInfoBriDoc True lastInfo bd info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW infor <- mergeBriDocsW
-- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
(if shouldBreakAfter bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info)
@ -545,28 +563,27 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- personal preference to not break alignment for those, even if -- personal preference to not break alignment for those, even if
-- multiline. Really, this should be configurable.. (TODO) -- multiline. Really, this should be configurable.. (TODO)
shouldBreakAfter :: BriDoc -> Bool shouldBreakAfter :: BriDoc -> Bool
shouldBreakAfter bd = alignBreak && shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of
briDocIsMultiLine bd && case bd of (BDCols ColTyOpPrefix _) -> False
(BDCols ColTyOpPrefix _) -> False (BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncPrefix _) -> True (BDCols ColPatternsFuncInfix _) -> True
(BDCols ColPatternsFuncInfix _) -> True (BDCols ColPatterns _) -> True
(BDCols ColPatterns _) -> True (BDCols ColCasePattern _) -> True
(BDCols ColCasePattern _) -> True (BDCols ColBindingLine{} _) -> True
(BDCols ColBindingLine{} _) -> True (BDCols ColGuard _) -> True
(BDCols ColGuard _) -> True (BDCols ColGuardedBody _) -> True
(BDCols ColGuardedBody _) -> True (BDCols ColBindStmt _) -> True
(BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True
(BDCols ColDoLet _) -> True (BDCols ColRec _) -> False
(BDCols ColRec _) -> False (BDCols ColRecUpdate _) -> False
(BDCols ColRecUpdate _) -> False (BDCols ColRecDecl _) -> False
(BDCols ColRecDecl _) -> False (BDCols ColListComp _) -> False
(BDCols ColListComp _) -> False (BDCols ColList _) -> False
(BDCols ColList _) -> False (BDCols ColApp{} _) -> True
(BDCols ColApp{} _) -> True (BDCols ColTuple _) -> False
(BDCols ColTuple _) -> False (BDCols ColTuples _) -> False
(BDCols ColTuples _) -> False (BDCols ColOpPrefix _) -> False
(BDCols ColOpPrefix _) -> False _ -> True
_ -> True
mergeInfoBriDoc mergeInfoBriDoc
:: Bool :: Bool
@ -574,23 +591,22 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-> BriDoc -> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo -> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case \case
brdc@(BDCols colSig subDocs) brdc@(BDCols colSig subDocs)
| infoSig == colSig && length subLengthsInfos == length subDocs | infoSig == colSig && length subLengthsInfos == length subDocs -> do
-> do
let let
isLastList = if lastFlag isLastList = if lastFlag
then (==length subDocs) <$> [1 ..] then (== length subDocs) <$> [1 ..]
else repeat False else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos) let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map do -- update map
s <- StateS.get s <- StateS.get
let m = _cbs_map s let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s StateS.put s
{ _cbs_map = IntMapS.insert { _cbs_map = IntMapS.insert
@ -599,17 +615,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
m m
} }
return $ ColInfo infoInd colSig (zip curLengths infos) return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise | otherwise -> briDocToColInfo lastFlag brdc
-> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList = let
if lastFlag then (==length list) <$> [1 ..] else repeat False isLastList =
if lastFlag then (== length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd bd -> return $ ColInfoNo bd
@ -617,11 +633,11 @@ briDocToColInfo lastFlag = \case
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i (len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _ ) -> ColumnSpacingLeaf len (len, _) -> ColumnSpacingLeaf len
withAlloc withAlloc
:: Bool :: Bool
-> ( ColIndex -> ( ColIndex
-> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
) )
-> StateS.State ColBuildState ColInfo -> StateS.State ColBuildState ColInfo
@ -636,13 +652,14 @@ withAlloc lastFlag f = do
processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()
processInfo maxSpace m = \case processInfo maxSpace m = \case
ColInfoStart -> error "should not happen (TM)" ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc ColInfoNo doc -> layoutBriDocM doc
ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
do do
colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack alignMode <-
curX <- do mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do
state <- mGet state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state
@ -654,10 +671,11 @@ processInfo maxSpace m = \case
let colMax = min colMaxConf (curX + maxSpace) let colMax = min colMaxConf (curX + maxSpace)
-- tellDebugMess $ show curX -- tellDebugMess $ show curX
let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
let maxCols2 = list <&> \case let
(_, ColInfo i _ _) -> maxCols2 = list <&> \case
let Just (_, ms, _) = IntMapS.lookup i m in sum ms (_, ColInfo i _ _) ->
(l, _) -> l let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l
let maxCols = zipWith max maxCols1 maxCols2 let maxCols = zipWith max maxCols1 maxCols2
let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
-- handle the cases that the vertical alignment leads to more than max -- handle the cases that the vertical alignment leads to more than max
@ -668,46 +686,48 @@ processInfo maxSpace m = \case
-- sizes in such a way that it works _if_ we have sizes (*factor) -- sizes in such a way that it works _if_ we have sizes (*factor)
-- in each column. but in that line, in the last column, we will be -- in each column. but in that line, in the last column, we will be
-- forced to occupy the full vertical space, not reduced by any factor. -- forced to occupy the full vertical space, not reduced by any factor.
let fixedPosXs = case alignMode of let
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) fixedPosXs = case alignMode of
where ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)
factor :: Float = where
-- 0.0001 as an offering to the floating point gods. factor :: Float =
min -- 0.0001 as an offering to the floating point gods.
1.0001 min
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) 1.0001
offsets = (subtract curX) <$> posXs (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
fixed = offsets <&> fromIntegral .> (*factor) .> truncate offsets = (subtract curX) <$> posXs
_ -> posXs fixed = offsets <&> fromIntegral .> (* factor) .> truncate
let spacings = zipWith (-) _ -> posXs
(List.tail fixedPosXs ++ [min maxX colMax]) let
fixedPosXs spacings =
zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs
-- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "ind = " ++ show ind
-- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "maxCols = " ++ show maxCols
-- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
-- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "list = " ++ show list
-- tellDebugMess $ "maxSpace = " ++ show maxSpace -- tellDebugMess $ "maxSpace = " ++ show maxSpace
let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do let
layoutWriteEnsureAbsoluteN destX alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
processInfo s m (snd x) layoutWriteEnsureAbsoluteN destX
noAlignAct = list `forM_` (snd .> processInfoIgnore) processInfo s m (snd x)
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ noAlignAct = list `forM_` (snd .> processInfoIgnore)
if List.last fixedPosXs + fst (List.last list) > colMax animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
-- per-item check if there is overflowing. if List.last fixedPosXs + fst (List.last list) > colMax
then noAlignAct -- per-item check if there is overflowing.
else alignAct then noAlignAct
else alignAct
case alignMode of case alignMode of
ColumnAlignModeDisabled -> noAlignAct ColumnAlignModeDisabled -> noAlignAct
ColumnAlignModeUnanimously | maxX <= colMax -> alignAct ColumnAlignModeUnanimously | maxX <= colMax -> alignAct
ColumnAlignModeUnanimously -> noAlignAct ColumnAlignModeUnanimously -> noAlignAct
ColumnAlignModeMajority limit | ratio >= limit -> animousAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct
ColumnAlignModeMajority{} -> noAlignAct ColumnAlignModeMajority{} -> noAlignAct
ColumnAlignModeAnimouslyScale{} -> animousAct ColumnAlignModeAnimouslyScale{} -> animousAct
ColumnAlignModeAnimously -> animousAct ColumnAlignModeAnimously -> animousAct
ColumnAlignModeAlways -> alignAct ColumnAlignModeAlways -> alignAct
processInfoIgnore :: LayoutConstraints m => ColInfo -> m () processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
processInfoIgnore = \case processInfoIgnore = \case
ColInfoStart -> error "should not happen (TM)" ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)

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

@ -3,42 +3,29 @@
module Language.Haskell.Brittany.Internal.BackendUtils where module Language.Haskell.Brittany.Internal.BackendUtils where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Either import qualified Data.Either
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey
, Annotation
)
import qualified Data.Text.Lazy.Builder as Text.Builder 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 Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Internal.Utils
import GHC ( Located ) traceLocal :: (MonadMultiState LayoutState m) => a -> m ()
traceLocal
:: (MonadMultiState LayoutState m)
=> a
-> m ()
traceLocal _ = return () traceLocal _ = return ()
layoutWriteAppend layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Text => Text
-> m () -> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
@ -54,15 +41,13 @@ layoutWriteAppend t = do
mTell $ Text.Builder.fromText $ t mTell $ Text.Builder.fromText $ t
mModify $ \s -> s mModify $ \s -> s
{ _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of
Left c -> c + Text.length t + spaces Left c -> c + Text.length t + spaces
Right{} -> Text.length t + spaces Right{} -> Text.length t + spaces
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
} }
layoutWriteAppendSpaces layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteAppendSpaces i = do layoutWriteAppendSpaces i = do
@ -70,20 +55,18 @@ layoutWriteAppendSpaces i = do
unless (i == 0) $ do unless (i == 0) $ do
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state
} }
layoutWriteAppendMultiline layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> [Text] => [Text]
-> m () -> m ()
layoutWriteAppendMultiline ts = do layoutWriteAppendMultiline ts = do
traceLocal ("layoutWriteAppendMultiline", ts) traceLocal ("layoutWriteAppendMultiline", ts)
case ts of case ts of
[] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too.
(l:lr) -> do (l : lr) -> do
layoutWriteAppend l layoutWriteAppend l
lr `forM_` \x -> do lr `forM_` \x -> do
layoutWriteNewline layoutWriteNewline
@ -91,16 +74,15 @@ layoutWriteAppendMultiline ts = do
-- adds a newline and adds spaces to reach the base column. -- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewlineBlock = do layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock") traceLocal ("layoutWriteNewlineBlock")
state <- mGet state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1 mSet $ state
, _lstate_addSepSpace = Just $ lstate_baseY state { _lstate_curYOrAddNewline = Right 1
} , _lstate_addSepSpace = Just $ lstate_baseY state
}
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m) => Int -> m () -- , MonadMultiWriter (Seq String) m) => Int -> m ()
@ -116,13 +98,13 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state -- else _lstate_indLevelLinger state + i - _lstate_curY state
-- } -- }
layoutSetCommentCol layoutSetCommentCol :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol = do layoutSetCommentCol = do
state <- mGet state <- mGet
let col = case _lstate_curYOrAddNewline state of let
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) col = case _lstate_curYOrAddNewline state of
Right{} -> lstate_baseY state Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col) traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state) unless (Data.Maybe.isJust $ _lstate_commentCol state)
$ mSet state { _lstate_commentCol = Just col } $ mSet state { _lstate_commentCol = Just col }
@ -130,9 +112,7 @@ layoutSetCommentCol = do
-- This is also used to move to non-comments in a couple of places. Seems -- This is also used to move to non-comments in a couple of places. Seems
-- to be harmless so far.. -- to be harmless so far..
layoutMoveToCommentPos layoutMoveToCommentPos
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> Int -> Int
-> Int -> Int
@ -142,38 +122,35 @@ layoutMoveToCommentPos y x commentLines = do
state <- mGet state <- mGet
mSet state mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y Left i -> if y == 0 then Left i else Right y
Right{} -> Right y Right{} -> Right y
, _lstate_addSepSpace = , _lstate_addSepSpace =
Just $ if Data.Maybe.isJust (_lstate_commentCol state) Just $ if Data.Maybe.isJust (_lstate_commentCol state)
then case _lstate_curYOrAddNewline state of then case _lstate_curYOrAddNewline state of
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x
else if y == 0 then x else _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = , _lstate_commentCol = Just $ case _lstate_commentCol state of
Just $ case _lstate_commentCol state of Just existing -> existing
Just existing -> existing Nothing -> case _lstate_curYOrAddNewline state of
Nothing -> case _lstate_curYOrAddNewline state of Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Right{} -> lstate_baseY state
Right{} -> lstate_baseY state
, _lstate_commentNewlines = , _lstate_commentNewlines =
_lstate_commentNewlines state + y + commentLines - 1 _lstate_commentNewlines state + y + commentLines - 1
} }
-- | does _not_ add spaces to again reach the current base column. -- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewline = do layoutWriteNewline = do
traceLocal ("layoutWriteNewline") traceLocal ("layoutWriteNewline")
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1 Left{} -> Right 1
Right i -> Right (i + 1) Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
} }
_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () _layoutResetCommentNewlines :: MonadMultiState LayoutState m => m ()
@ -181,77 +158,67 @@ _layoutResetCommentNewlines = do
mModify $ \state -> state { _lstate_commentNewlines = 0 } mModify $ \state -> state { _lstate_commentNewlines = 0 }
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteEnsureNewlineBlock = do layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock") traceLocal ("layoutWriteEnsureNewlineBlock")
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1 Left{} -> Right 1
Right i -> Right $ max 1 i Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
layoutWriteEnsureAbsoluteN layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
state <- mGet state <- mGet
let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of let
(Just c , _ ) -> n - c diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
(Nothing, Left i ) -> n - i (Just c, _) -> n - c
(Nothing, Right{}) -> n (Nothing, Left i) -> n - i
(Nothing, Right{}) -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff > 0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to
-- at least (Just 1), so we won't -- at least (Just 1), so we won't
-- overwrite any old value in any -- overwrite any old value in any
-- bad way. -- bad way.
}
layoutBaseYPushInternal layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutBaseYPushInternal i = do layoutBaseYPushInternal i = do
traceLocal ("layoutBaseYPushInternal", i) traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutBaseYPopInternal layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPopInternal = do layoutBaseYPopInternal = do
traceLocal ("layoutBaseYPopInternal") traceLocal ("layoutBaseYPopInternal")
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
layoutIndentLevelPushInternal layoutIndentLevelPushInternal
:: (MonadMultiState LayoutState m) :: (MonadMultiState LayoutState m) => Int -> m ()
=> Int
-> m ()
layoutIndentLevelPushInternal i = do layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i) traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s
, _lstate_indLevels = i : _lstate_indLevels s { _lstate_indLevelLinger = lstate_indLevel s
} , _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal = do layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal") traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s
, _lstate_indLevels = List.tail $ _lstate_indLevels s { _lstate_indLevelLinger = lstate_indLevel s
} , _lstate_indLevels = List.tail $ _lstate_indLevels s
}
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m ()
layoutRemoveIndentLevelLinger = do layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }
}
layoutWithAddBaseCol layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m :: ( MonadMultiWriter Text.Builder.Builder m
@ -283,9 +250,7 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWithAddBaseColNBlock layoutWithAddBaseColNBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -298,27 +263,23 @@ layoutWithAddBaseColNBlock amount m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWriteEnsureBlock layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteEnsureBlock = do layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock") traceLocal ("layoutWriteEnsureBlock")
state <- mGet state <- mGet
let let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
(Nothing, Left i ) -> lstate_baseY state - i (Nothing, Left i) -> lstate_baseY state - i
(Nothing, Right{}) -> lstate_baseY state (Nothing, Right{}) -> lstate_baseY state
(Just sp, Left i ) -> max sp (lstate_baseY state - i) (Just sp, Left i) -> max sp (lstate_baseY state - i)
(Just sp, Right{}) -> max sp (lstate_baseY state) (Just sp, Right{}) -> max sp (lstate_baseY state)
-- when (diff>0) $ layoutWriteNewlineBlock -- when (diff>0) $ layoutWriteNewlineBlock
when (diff > 0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff } mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWithAddBaseColN layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -328,39 +289,36 @@ layoutWithAddBaseColN amount m = do
m m
layoutBaseYPopInternal layoutBaseYPopInternal
layoutBaseYPushCur layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur = do layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur") traceLocal ("layoutBaseYPushCur")
state <- mGet state <- mGet
case _lstate_commentCol state of case _lstate_commentCol state of
Nothing -> Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> layoutBaseYPushInternal (i + j) (Left i, Just j) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i (Left i, Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do layoutBaseYPop = do
traceLocal ("layoutBaseYPop") traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal layoutBaseYPopInternal
layoutIndentLevelPushCur layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur = do layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur") traceLocal ("layoutIndentLevelPushCur")
state <- mGet state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of let
(Left i , Just j ) -> i + j y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Nothing) -> i (Left i, Just j) -> i + j
(Right{}, Just j ) -> j (Left i, Nothing) -> i
(Right{}, Nothing) -> 0 (Right{}, Just j) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y layoutIndentLevelPushInternal y
layoutIndentLevelPop layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop = do layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop") traceLocal ("layoutIndentLevelPop")
layoutIndentLevelPopInternal layoutIndentLevelPopInternal
@ -370,12 +328,12 @@ layoutIndentLevelPop = do
-- make sense. -- make sense.
layoutRemoveIndentLevelLinger layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m) layoutAddSepSpace :: (MonadMultiState LayoutState m) => m ()
=> m ()
layoutAddSepSpace = do layoutAddSepSpace = do
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state
}
-- TODO: when refactoring is complete, the other version of this method -- TODO: when refactoring is complete, the other version of this method
-- can probably be removed. -- can probably be removed.
@ -390,7 +348,7 @@ moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey) traceLocal ("moveToExactAnn", annKey)
anns <- mAsk anns <- mAsk
case Map.lookup annKey anns of case Map.lookup annKey anns of
Nothing -> return () Nothing -> return ()
Just ann -> do Just ann -> do
-- curY <- mGet <&> _lstate_curY -- curY <- mGet <&> _lstate_curY
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
@ -399,19 +357,19 @@ moveToExactAnn annKey = do
moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state -> moveToY y = mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of let
Left i -> if y == 0 then Left i else Right y upd = case _lstate_curYOrAddNewline state of
Right i -> Right $ max y i Left i -> if y == 0 then Left i else Right y
in state Right i -> Right $ max y i
{ _lstate_curYOrAddNewline = upd in
, _lstate_addSepSpace = if Data.Either.isRight upd state
then { _lstate_curYOrAddNewline = upd
_lstate_commentCol state , _lstate_addSepSpace = if Data.Either.isRight upd
<|> _lstate_addSepSpace state then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
<|> Just (lstate_baseY state) (lstate_baseY state)
else Nothing else Nothing
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
-- fixMoveToLineByIsNewline :: MonadMultiState -- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int -- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do -- fixMoveToLineByIsNewline x = do
@ -421,9 +379,7 @@ moveToY y = mModify $ \state ->
-- else x -- else x
ppmMoveToExactLoc ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
=> ExactPrint.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " " replicateM_ y $ mTell $ Text.Builder.fromString " "
@ -439,75 +395,77 @@ layoutWritePriorComments
layoutWritePriorComments ast = do layoutWritePriorComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let key = ExactPrint.mkAnnKey ast let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns (\ann -> ann { ExactPrint.annPriorComments = [] })
key
anns
} }
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just priors -> do Just priors -> do
unless (null priors) $ layoutSetCommentCol unless (null priors) $ layoutSetCommentCol
priors `forM_` \( ExactPrint.Comment comment _ _ priors
, ExactPrint.DP (x, y) `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do
) -> do replicateM_ x layoutWriteNewline
replicateM_ x layoutWriteNewline layoutWriteAppendSpaces y
layoutWriteAppendSpaces y layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
-- TODO: update and use, or clean up. Currently dead code. -- TODO: update and use, or clean up. Currently dead code.
-- this currently only extracs from the `annsDP` field of Annotations. -- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the -- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..". -- "..`annFollowingComments` are only added by AST transformations ..".
layoutWritePostComments :: (Data.Data.Data ast, layoutWritePostComments
MonadMultiWriter Text.Builder.Builder m, :: ( Data.Data.Data ast
MonadMultiState LayoutState m) , MonadMultiWriter Text.Builder.Builder m
=> Located ast -> m () , MonadMultiState LayoutState m
)
=> Located ast
-> m ()
layoutWritePostComments ast = do layoutWritePostComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let key = ExactPrint.mkAnnKey ast let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) (\ann -> ann { ExactPrint.annFollowingComments = [] })
key key
anns anns
} }
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just posts -> do Just posts -> do
unless (null posts) $ layoutSetCommentCol unless (null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Comment comment _ _ posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
, ExactPrint.DP (x, y) do
) -> do replicateM_ x layoutWriteNewline
replicateM_ x layoutWriteNewline layoutWriteAppend $ Text.pack $ replicate y ' '
layoutWriteAppend $ Text.pack $ replicate y ' ' mModify $ \s -> s { _lstate_addSepSpace = Nothing }
mModify $ \s -> s { _lstate_addSepSpace = Nothing } layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment layoutIndentRestorePostComment
:: ( MonadMultiState LayoutState m :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
, MonadMultiWriter Text.Builder.Builder m
)
=> m () => m ()
layoutIndentRestorePostComment = do layoutIndentRestorePostComment = do
state <- mGet state <- mGet
let mCommentCol = _lstate_commentCol state let mCommentCol = _lstate_commentCol state
let eCurYAddNL = _lstate_curYOrAddNewline state let eCurYAddNL = _lstate_curYOrAddNewline state
mModify $ \s -> s { _lstate_commentCol = Nothing mModify
, _lstate_commentNewlines = 0 $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 }
}
case (mCommentCol, eCurYAddNL) of case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do (Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe
_ -> return () 0
(_lstate_addSepSpace state)
_ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m, -- MonadMultiWriter Text.Builder.Builder m,

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

@ -3,185 +3,174 @@
module Language.Haskell.Brittany.Internal.Config where module Language.Haskell.Brittany.Internal.Config where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Bool as Bool import qualified Data.Bool as Bool
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 import qualified Data.ByteString.Char8
import Data.CZipWith
import Data.Coerce (coerce)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified GHC.OldList as List
import qualified System.Directory
import qualified System.IO
import qualified Data.Yaml import qualified Data.Yaml
import Data.CZipWith 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.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
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified System.IO
import UI.Butcher.Monadic
import UI.Butcher.Monadic
import qualified System.Console.CmdArgs.Explicit
as CmdArgs
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
import Language.Haskell.Brittany.Internal.Utils
import Data.Coerce ( coerce
)
import qualified Data.List.NonEmpty as NonEmpty
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
staticDefaultConfig :: Config staticDefaultConfig :: Config
staticDefaultConfig = Config staticDefaultConfig = Config
{ _conf_version = coerce (1 :: Int) { _conf_version = coerce (1 :: Int)
, _conf_debug = DebugConfig , _conf_debug = DebugConfig
{ _dconf_dump_config = coerce False { _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False , _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False , _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = coerce False , _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = coerce False , _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_alt = coerce False
, _dconf_dump_bridoc_simpl_floating = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False
, _dconf_dump_bridoc_simpl_par = coerce False , _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = coerce False , _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = coerce False , _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False , _dconf_dump_bridoc_final = coerce False
, _dconf_roundtrip_exactprint_only = coerce False , _dconf_roundtrip_exactprint_only = coerce False
} }
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int) { _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True , _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True , _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (50 :: Int) , _lconfig_importColumn = coerce (50 :: Int)
, _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_importAsColumn = coerce (50 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False , _lconfig_hangingTypeSignature = coerce False
, _lconfig_reformatModulePreamble = coerce True , _lconfig_reformatModulePreamble = coerce True
, _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowSingleLineExportList = coerce False
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False -- , _lconfig_allowSinglelineRecord = coerce False
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False { _econf_produceOutputOnErrors = coerce False
, _econf_Werror = coerce False , _econf_Werror = coerce False
, _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline
, _econf_omit_output_valid_check = coerce False , _econf_omit_output_valid_check = coerce False
} }
, _conf_preprocessor = PreProcessorConfig , _conf_preprocessor = PreProcessorConfig
{ _ppconf_CPPMode = coerce CPPModeAbort { _ppconf_CPPMode = coerce CPPModeAbort
, _ppconf_hackAroundIncludes = coerce False , _ppconf_hackAroundIncludes = coerce False
} }
, _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_forward = ForwardOptions { _options_ghc = Identity [] }
, _conf_roundtrip_exactprint_only = coerce False , _conf_roundtrip_exactprint_only = coerce False
, _conf_disable_formatting = coerce False , _conf_disable_formatting = coerce False
, _conf_obfuscate = coerce False , _conf_obfuscate = coerce False
} }
forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled :: ForwardOptions
forwardOptionsSyntaxExtsEnabled = ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions
{ _options_ghc = Identity { _options_ghc = Identity
[ "-XLambdaCase" [ "-XLambdaCase"
, "-XMultiWayIf" , "-XMultiWayIf"
, "-XGADTs" , "-XGADTs"
, "-XPatternGuards" , "-XPatternGuards"
, "-XViewPatterns" , "-XViewPatterns"
, "-XTupleSections" , "-XTupleSections"
, "-XExplicitForAll" , "-XExplicitForAll"
, "-XImplicitParams" , "-XImplicitParams"
, "-XQuasiQuotes" , "-XQuasiQuotes"
, "-XTemplateHaskell" , "-XTemplateHaskell"
, "-XBangPatterns" , "-XBangPatterns"
, "-XTypeApplications" , "-XTypeApplications"
] ]
} }
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } -- brittany-next-binding --columns 200
cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe)
cmdlineConfigParser = do cmdlineConfigParser = do
-- TODO: why does the default not trigger; ind never should be []!! -- TODO: why does the default not trigger; ind never should be []!!
ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at")
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)")
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")
dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")
dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")
dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)")
wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")
roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")
optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")
disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.")
obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.")
return $ Config return $ Config
{ _conf_version = mempty { _conf_version = mempty
, _conf_debug = DebugConfig , _conf_debug = DebugConfig
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
, _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
, _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
, _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
, _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating
, _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
, _dconf_roundtrip_exactprint_only = mempty , _dconf_roundtrip_exactprint_only = mempty
} }
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols { _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty , _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind , _lconfig_indentAmount = optionConcat ind
, _lconfig_indentWhereSpecial = mempty -- falseToNothing _ , _lconfig_indentWhereSpecial = mempty -- falseToNothing _
, _lconfig_indentListSpecial = mempty -- falseToNothing _ , _lconfig_indentListSpecial = mempty -- falseToNothing _
, _lconfig_importColumn = optionConcat importCol , _lconfig_importColumn = optionConcat importCol
, _lconfig_importAsColumn = optionConcat importAsCol , _lconfig_importAsColumn = optionConcat importAsCol
, _lconfig_altChooser = mempty , _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty , _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty , _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_alignmentBreakOnMultiline = mempty
, _lconfig_hangingTypeSignature = mempty , _lconfig_hangingTypeSignature = mempty
, _lconfig_reformatModulePreamble = mempty , _lconfig_reformatModulePreamble = mempty
, _lconfig_allowSingleLineExportList = mempty , _lconfig_allowSingleLineExportList = mempty
, _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_allowHangingQuasiQuotes = mempty
, _lconfig_experimentalSemicolonNewlines = mempty , _lconfig_experimentalSemicolonNewlines = mempty
-- , _lconfig_allowSinglelineRecord = mempty -- , _lconfig_allowSinglelineRecord = mempty
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError , _econf_Werror = wrapLast $ falseToNothing wError
, _econf_ExactPrintFallback = mempty , _econf_ExactPrintFallback = mempty
, _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck
} }
, _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty }
, _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] }
, _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly
, _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting
, _conf_obfuscate = wrapLast $ falseToNothing obfuscate , _conf_obfuscate = wrapLast $ falseToNothing obfuscate
} }
where where
falseToNothing = Bool.bool Nothing (Just True) falseToNothing = Bool.bool Nothing (Just True)
@ -228,8 +217,8 @@ readConfig path = do
fileConf <- case Data.Yaml.decodeEither' contents of fileConf <- case Data.Yaml.decodeEither' contents of
Left e -> do Left e -> do
liftIO liftIO
$ putStrErrLn $ putStrErrLn
$ "error reading in brittany config from " $ "error reading in brittany config from "
++ path ++ path
++ ":" ++ ":"
liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e)
@ -243,11 +232,12 @@ readConfig path = do
userConfigPath :: IO System.IO.FilePath userConfigPath :: IO System.IO.FilePath
userConfigPath = do userConfigPath = do
userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"
userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
let searchDirs = [userBritPathSimple, userBritPathXdg] let searchDirs = [userBritPathSimple, userBritPathXdg]
globalConfig <- Directory.findFileWith Directory.doesFileExist globalConfig <- Directory.findFileWith
searchDirs Directory.doesFileExist
"config.yaml" searchDirs
"config.yaml"
maybe (writeUserConfig userBritPathXdg) pure globalConfig maybe (writeUserConfig userBritPathXdg) pure globalConfig
where where
writeUserConfig dir = do writeUserConfig dir = do
@ -259,7 +249,7 @@ userConfigPath = do
-- | Searches for a local (per-project) brittany config starting from a given directory -- | Searches for a local (per-project) brittany config starting from a given directory
findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath)
findLocalConfigPath dir = do findLocalConfigPath dir = do
let dirParts = FilePath.splitDirectories dir let dirParts = FilePath.splitDirectories dir
-- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"]
let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts)
Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml"
@ -271,8 +261,9 @@ readConfigs
-> MaybeT IO Config -> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths configs <- readConfig `mapM` configPaths
let merged = Semigroup.sconcat let
$ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) merged =
Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
return $ cZipWith fromOptionIdentity staticDefaultConfig merged return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs -- | Reads provided configs

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

@ -7,63 +7,54 @@
module Language.Haskell.Brittany.Internal.Config.Types where 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 Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils () import Language.Haskell.Brittany.Internal.PreludeUtils ()
import qualified Data.Semigroup as Semigroup
import GHC.Generics
import Data.Data ( Data )
import Data.Coerce ( Coercible, coerce )
import Data.Semigroup.Generic
import Data.Semigroup ( Last )
import Data.CZipWith
confUnpack :: Coercible a b => Identity a -> b confUnpack :: Coercible a b => Identity a -> b
confUnpack (Identity x) = coerce x confUnpack (Identity x) = coerce x
data CDebugConfig f = DebugConfig data CDebugConfig f = DebugConfig
{ _dconf_dump_config :: f (Semigroup.Last Bool) { _dconf_dump_config :: f (Semigroup.Last Bool)
, _dconf_dump_annotations :: f (Semigroup.Last Bool) , _dconf_dump_annotations :: f (Semigroup.Last Bool)
, _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool)
, _dconf_dump_ast_full :: f (Semigroup.Last Bool) , _dconf_dump_ast_full :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)
, _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CLayoutConfig f = LayoutConfig data CLayoutConfig f = LayoutConfig
{ _lconfig_cols :: f (Last Int) -- the thing that has default 80. { _lconfig_cols :: f (Last Int) -- the thing that has default 80.
, _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentPolicy :: f (Last IndentPolicy)
, _lconfig_indentAmount :: f (Last Int) , _lconfig_indentAmount :: f (Last Int)
, _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO).
, _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for ","
-- when creating zero-indentation -- when creating zero-indentation
-- multi-line list literals. -- multi-line list literals.
, _lconfig_importColumn :: f (Last Int) , _lconfig_importColumn :: f (Last Int)
-- ^ for import statement layouting, column at which to align the -- ^ for import statement layouting, column at which to align the
-- elements to be imported from a module. -- elements to be imported from a module.
-- It is expected that importAsColumn >= importCol. -- It is expected that importAsColumn >= importCol.
, _lconfig_importAsColumn :: f (Last Int) , _lconfig_importAsColumn :: f (Last Int)
-- ^ for import statement layouting, column at which put the module's -- ^ for import statement layouting, column at which put the module's
-- "as" name (which also affects the positioning of the "as" keyword). -- "as" name (which also affects the positioning of the "as" keyword).
-- It is expected that importAsColumn >= importCol. -- It is expected that importAsColumn >= importCol.
, _lconfig_altChooser :: f (Last AltChooser) , _lconfig_altChooser :: f (Last AltChooser)
, _lconfig_columnAlignMode :: f (Last ColumnAlignMode) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode)
, _lconfig_alignmentLimit :: f (Last Int) , _lconfig_alignmentLimit :: f (Last Int)
-- roughly speaking, this sets an upper bound to the number of spaces -- roughly speaking, this sets an upper bound to the number of spaces
-- inserted to create horizontal alignment. -- inserted to create horizontal alignment.
-- More specifically, if 'xs' are the widths of the columns in some -- More specifically, if 'xs' are the widths of the columns in some
@ -148,17 +139,17 @@ data CLayoutConfig f = LayoutConfig
-- -- > , y :: Double -- -- > , y :: Double
-- -- > } -- -- > }
} }
deriving (Generic) deriving Generic
data CForwardOptions f = ForwardOptions data CForwardOptions f = ForwardOptions
{ _options_ghc :: f [String] { _options_ghc :: f [String]
} }
deriving (Generic) deriving Generic
data CErrorHandlingConfig f = ErrorHandlingConfig data CErrorHandlingConfig f = ErrorHandlingConfig
{ _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
, _econf_Werror :: f (Semigroup.Last Bool) , _econf_Werror :: f (Semigroup.Last Bool)
, _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode)
-- ^ Determines when to fall back on the exactprint'ed output when -- ^ Determines when to fall back on the exactprint'ed output when
-- syntactical constructs are encountered which are not yet handled by -- syntactical constructs are encountered which are not yet handled by
-- brittany. -- brittany.
@ -168,21 +159,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig
-- has different semantics than the code pre-transformation. -- has different semantics than the code pre-transformation.
, _econf_omit_output_valid_check :: f (Semigroup.Last Bool) , _econf_omit_output_valid_check :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CPreProcessorConfig f = PreProcessorConfig data CPreProcessorConfig f = PreProcessorConfig
{ _ppconf_CPPMode :: f (Semigroup.Last CPPMode) { _ppconf_CPPMode :: f (Semigroup.Last CPPMode)
, _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CConfig f = Config data CConfig f = Config
{ _conf_version :: f (Semigroup.Last Int) { _conf_version :: f (Semigroup.Last Int)
, _conf_debug :: CDebugConfig f , _conf_debug :: CDebugConfig f
, _conf_layout :: CLayoutConfig f , _conf_layout :: CLayoutConfig f
, _conf_errorHandling :: CErrorHandlingConfig f , _conf_errorHandling :: CErrorHandlingConfig f
, _conf_forward :: CForwardOptions f , _conf_forward :: CForwardOptions f
, _conf_preprocessor :: CPreProcessorConfig f , _conf_preprocessor :: CPreProcessorConfig f
, _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
-- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- ^ this field is somewhat of a duplicate of the one in DebugConfig.
-- It is used for per-declaration disabling by the inline config -- It is used for per-declaration disabling by the inline config
@ -193,10 +184,9 @@ data CConfig f = Config
-- module. Useful for wildcard application -- module. Useful for wildcard application
-- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something
-- in that direction). -- in that direction).
, _conf_obfuscate :: f (Semigroup.Last Bool) , _conf_obfuscate :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
type DebugConfig = CDebugConfig Identity type DebugConfig = CDebugConfig Identity
type LayoutConfig = CLayoutConfig Identity type LayoutConfig = CLayoutConfig Identity

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

@ -18,22 +18,16 @@
module Language.Haskell.Brittany.Internal.Config.Types.Instances where module Language.Haskell.Brittany.Internal.Config.Types.Instances where
import Language.Haskell.Brittany.Internal.Prelude
import Data.Yaml
import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson.Types as Aeson
import Data.Yaml
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany :: Aeson.Options
aesonDecodeOptionsBrittany = Aeson.defaultOptions aesonDecodeOptionsBrittany = Aeson.defaultOptions
{ Aeson.omitNothingFields = True { Aeson.omitNothingFields = True
, Aeson.fieldLabelModifier = dropWhile (=='_') , Aeson.fieldLabelModifier = dropWhile (== '_')
} }
instance FromJSON (CDebugConfig Maybe) where instance FromJSON (CDebugConfig Maybe) where
@ -108,17 +102,18 @@ instance ToJSON (CConfig Maybe) where
-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid
-- config file content. -- config file content.
instance FromJSON (CConfig Maybe) where instance FromJSON (CConfig Maybe) where
parseJSON (Object v) = Config parseJSON (Object v) =
<$> v .:? Key.fromString "conf_version" Config
<*> v .:?= Key.fromString "conf_debug" <$> (v .:? Key.fromString "conf_version")
<*> v .:?= Key.fromString "conf_layout" <*> (v .:?= Key.fromString "conf_debug")
<*> v .:?= Key.fromString "conf_errorHandling" <*> (v .:?= Key.fromString "conf_layout")
<*> v .:?= Key.fromString "conf_forward" <*> (v .:?= Key.fromString "conf_errorHandling")
<*> v .:?= Key.fromString "conf_preprocessor" <*> (v .:?= Key.fromString "conf_forward")
<*> v .:? Key.fromString "conf_roundtrip_exactprint_only" <*> (v .:?= Key.fromString "conf_preprocessor")
<*> v .:? Key.fromString "conf_disable_formatting" <*> (v .:? Key.fromString "conf_roundtrip_exactprint_only")
<*> v .:? Key.fromString "conf_obfuscate" <*> (v .:? Key.fromString "conf_disable_formatting")
parseJSON invalid = Aeson.typeMismatch "Config" invalid <*> (v .:? Key.fromString "conf_obfuscate")
parseJSON invalid = Aeson.typeMismatch "Config" invalid
-- Pretends that the value is {} when the key is not present. -- Pretends that the value is {} when the key is not present.
(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a

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

@ -7,47 +7,34 @@
module Language.Haskell.Brittany.Internal.ExactPrintUtils where module Language.Haskell.Brittany.Internal.ExactPrintUtils where
import Control.Exception
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.State.Class as State.Class
import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.Except as ExceptT
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.Data
import qualified Data.Foldable as Foldable 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.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified System.IO import GHC (GenLocated(L))
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Data
import Data.HList.HList
import GHC ( GenLocated(L) )
import qualified GHC.Driver.Session as GHC
import qualified GHC hiding (parseModule) import qualified GHC hiding (parseModule)
import qualified GHC.Types.SrcLoc as GHC import GHC.Data.Bag
import qualified GHC.Driver.CmdLine as GHC import qualified GHC.Driver.CmdLine as GHC
import qualified GHC.Driver.Session as GHC
import GHC.Hs import GHC.Hs
import GHC.Data.Bag import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.SrcLoc (Located, SrcSpan)
import GHC.Types.SrcLoc ( SrcSpan, Located ) import Language.Haskell.Brittany.Internal.Config.Types
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 as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO
import qualified Data.Generics as SYB
import Control.Exception
-- import Data.Generics.Schemes
parseModule parseModule
:: [String] :: [String]
@ -67,7 +54,7 @@ parseModuleWithCpp
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleWithCpp cpp opts args fp dynCheck = parseModuleWithCpp cpp opts args fp dynCheck =
ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
dflags0 <- lift $ GHC.getSessionDynFlags dflags0 <- lift $ GHC.getSessionDynFlags
(dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine
dflags0 dflags0
(GHC.noLoc <$> ("-hide-all-packages" : args)) (GHC.noLoc <$> ("-hide-all-packages" : args))
@ -79,17 +66,20 @@ parseModuleWithCpp cpp opts args fp dynCheck =
void $ lift $ GHC.setSessionDynFlags dflags1 void $ lift $ GHC.setSessionDynFlags dflags1
dflags2 <- lift $ ExactPrint.initDynFlags fp dflags2 <- lift $ ExactPrint.initDynFlags fp
unless (null leftover) unless (null leftover)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: " $ "when parsing ghc flags: leftover flags: "
++ show (leftover <&> \(L _ s) -> s) ++ show (leftover <&> \(L _ s) -> s)
unless (null warnings) unless (null warnings)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: " $ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> warnExtractorCompat) ++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) either
(\(a, m) -> pure (a, m, x)) (\err -> ExceptT.throwE $ "transform error: " ++ show
(bagToList (show <$> err))
)
(\(a, m) -> pure (a, m, x))
$ ExactPrint.postParseTransform res opts $ ExactPrint.postParseTransform res opts
parseModuleFromString parseModuleFromString
@ -107,46 +97,51 @@ parseModuleFromString args fp dynCheck str =
-- bridoc transformation stuff. -- bridoc transformation stuff.
-- (reminder to update note on `parsePrintModule` if this changes.) -- (reminder to update note on `parsePrintModule` if this changes.)
mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str
(dflags1, leftover, warnings) <- lift (dflags1, leftover, warnings) <- lift
$ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)
unless (null leftover) unless (null leftover)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: " $ "when parsing ghc flags: leftover flags: "
++ show (leftover <&> \(L _ s) -> s) ++ show (leftover <&> \(L _ s) -> s)
unless (null warnings) unless (null warnings)
$ ExceptT.throwE $ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: " $ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> warnExtractorCompat) ++ show (warnings <&> warnExtractorCompat)
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of case res of
Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) Left err ->
Right (a , m ) -> pure (a, m, dynCheckRes) ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
Right (a, m) -> pure (a, m, dynCheckRes)
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do commentAnnFixTransformGlob ast = do
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) let
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
const Seq.empty extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
`SYB.ext1Q` const Seq.empty
(\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) `SYB.ext1Q` (\l@(L span _) ->
Seq.singleton (span, ExactPrint.mkAnnKey l)
)
let nodes = SYB.everything (<>) extract ast let nodes = SYB.everything (<>) extract ast
let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey let
annsMap = Map.fromListWith annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
(const id) annsMap = Map.fromListWith
[ (GHC.realSrcSpanEnd span, annKey) (const id)
| (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes [ (GHC.realSrcSpanEnd span, annKey)
] | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
]
nodes `forM_` (snd .> processComs annsMap) nodes `forM_` (snd .> processComs annsMap)
where where
processComs annsMap annKey1 = do processComs annsMap annKey1 = do
mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn <- State.Class.gets fst <&> Map.lookup annKey1
mAnn `forM_` \ann1 -> do mAnn `forM_` \ann1 -> do
let priors = ExactPrint.annPriorComments ann1 let
follows = ExactPrint.annFollowingComments ann1 priors = ExactPrint.annPriorComments ann1
assocs = ExactPrint.annsDP ann1 follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let let
processCom processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos) :: (ExactPrint.Comment, ExactPrint.DeltaPos)
@ -158,31 +153,32 @@ commentAnnFixTransformGlob ast = do
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False move $> False
(x, y) | x == y -> move $> False (x, y) | x == y -> move $> False
_ -> return True _ -> return True
where where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.realSrcSpanStart annKeyLoc1 loc1 = GHC.realSrcSpanStart annKeyLoc1
loc2 = GHC.realSrcSpanStart annKeyLoc2 loc2 = GHC.realSrcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns -> move = ExactPrint.modifyAnnsT $ \anns ->
let let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2 ann2' = ann2
{ ExactPrint.annFollowingComments = { ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair] ExactPrint.annFollowingComments ann2 ++ [comPair]
} }
in in Map.insert annKey2 ann2' anns
Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node. _ -> return True -- retain comment at current node.
priors' <- filterM processCom priors priors' <- filterM processCom priors
follows' <- filterM processCom follows follows' <- filterM processCom follows
assocs' <- flip filterM assocs $ \case assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp) (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True _ -> return True
let ann1' = ann1 { ExactPrint.annPriorComments = priors' let
, ExactPrint.annFollowingComments = follows' ann1' = ann1
, ExactPrint.annsDP = assocs' { ExactPrint.annPriorComments = priors'
} , ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs'
}
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
@ -270,29 +266,30 @@ extractToplevelAnns lmod anns = output
| (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
] ]
declMap = declMap1 `Map.union` declMap2 declMap = declMap1 `Map.union` declMap2
modKey = ExactPrint.mkAnnKey lmod modKey = ExactPrint.mkAnnKey lmod
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns 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 :: (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) groupMap f = Map.foldlWithKey'
Map.empty (\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty
where where
insert k a Nothing = Just (Map.singleton k a) insert k a Nothing = Just (Map.singleton k a)
insert k a (Just m) = Just (Map.insert k a m) insert k a (Just m) = Just (Map.insert k a m)
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = SYB.everything foldedAnnKeys ast = SYB.everything
Set.union Set.union
( \x -> maybe (\x -> maybe
Set.empty Set.empty
Set.singleton Set.singleton
[ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x) | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
]
-- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- 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 -- even though it is passed to mkAnnKey above, which only accepts
-- SrcSpan. -- SrcSpan.
]
) )
ast ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
@ -301,8 +298,8 @@ foldedAnnKeys ast = SYB.everything
withTransformedAnns withTransformedAnns
:: Data ast :: Data ast
=> ast => ast
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
readers@(conf :+: anns :+: HNil) -> do readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS -- TODO: implement `local` for MultiReader/MultiRWS
@ -312,9 +309,10 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
pure x pure x
where where
f anns = f anns =
let ((), (annsBalanced, _), _) = let
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) ((), (annsBalanced, _), _) =
in annsBalanced ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced
warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat :: GHC.Warn -> String

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

@ -6,50 +6,37 @@
module Language.Haskell.Brittany.Internal.LayouterBasics where module Language.Haskell.Brittany.Internal.LayouterBasics where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS 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.Map as Map
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text 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 qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import qualified Control.Monad.Writer.Strict as Writer 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 as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate 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.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint 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 import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )
import qualified Data.Text.Lazy.Builder as Text.Builder
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import GHC.Types.Name.Reader ( RdrName(..) )
import GHC ( Located, GenLocated(L), moduleName, moduleNameString )
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name ( getOccString )
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import Data.Data
import qualified Data.Char as Char
import DataTreePrint
processDefault processDefault
:: ( ExactPrint.Annotate.Annotate ast :: ( ExactPrint.Annotate.Annotate ast
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter Text.Builder.Builder m
@ -67,7 +54,7 @@ processDefault x = do
-- the module (header). This would remove the need for this hack! -- the module (header). This would remove the need for this hack!
case str of case str of
"\n" -> return () "\n" -> return ()
_ -> mTell $ Text.Builder.fromString str _ -> mTell $ Text.Builder.fromString str
-- | Use ExactPrint's output for this node; add a newly generated inline comment -- | 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 -- at insertion position (meant to point out to the user that this node is
@ -79,9 +66,10 @@ briDocByExact
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExact ast = do briDocByExact ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
_dconf_dump_ast_unknown "ast"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True docExt ast anns True
-- | Use ExactPrint's output for this node. -- | Use ExactPrint's output for this node.
@ -95,9 +83,10 @@ briDocByExactNoComment
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do briDocByExactNoComment ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
_dconf_dump_ast_unknown "ast"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False docExt ast anns False
-- | Use ExactPrint's output for this node, presuming that this output does -- | Use ExactPrint's output for this node, presuming that this output does
@ -110,24 +99,26 @@ briDocByExactInlineOnly
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do briDocByExactInlineOnly infoStr ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
_dconf_dump_ast_unknown "ast"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
fallbackMode <- fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let exactPrintNode t = allocateNode $ BDFExternal let
(ExactPrint.Types.mkAnnKey ast) exactPrintNode t = allocateNode $ BDFExternal
(foldedAnnKeys ast) (ExactPrint.Types.mkAnnKey ast)
False (foldedAnnKeys ast)
t False
let errorAction = do t
mTell [ErrorUnknownNode infoStr ast] let
docLit errorAction = do
$ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
case (fallbackMode, Text.lines exactPrinted) of case (fallbackMode, Text.lines exactPrinted) of
(ExactPrintFallbackModeNever, _ ) -> errorAction (ExactPrintFallbackModeNever, _) -> errorAction
(_ , [t]) -> exactPrintNode (_, [t]) -> exactPrintNode
(Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
(ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
_ -> errorAction _ -> errorAction
@ -152,20 +143,21 @@ lrdrNameToTextAnnGen
lrdrNameToTextAnnGen f ast@(L _ n) = do lrdrNameToTextAnnGen f ast@(L _ n) = do
anns <- mAsk anns <- mAsk
let t = f $ rdrNameToText n let t = f $ rdrNameToText n
let hasUni x (ExactPrint.Types.G y, _) = x == y let
hasUni _ _ = False hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here. -- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the -- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe -- output. in such cases, resorting to byExact is probably the safe
-- choice. -- choice.
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
Nothing -> t Nothing -> t
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
Exact{} | t == Text.pack "()" -> t Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t _ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t _ | otherwise -> t
lrdrNameToTextAnn lrdrNameToTextAnn
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
@ -178,9 +170,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
=> Located RdrName => Located RdrName
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let f x = if x == Text.pack "Data.Type.Equality~" let
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh f x = if x == Text.pack "Data.Type.Equality~"
else x then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
lrdrNameToTextAnnGen f ast lrdrNameToTextAnnGen f ast
-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
@ -198,10 +191,11 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2 x <- lrdrNameToTextAnn ast2
let lit = if x == Text.pack "Data.Type.Equality~" let
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh lit = if x == Text.pack "Data.Type.Equality~"
else x then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
return $ if hasQuote then Text.cons '\'' lit else lit return $ if hasQuote then Text.cons '\'' lit else lit
askIndent :: (MonadMultiReader Config m) => m Int askIndent :: (MonadMultiReader Config m) => m Int
@ -219,12 +213,11 @@ extractRestComments ann =
ExactPrint.annFollowingComments ann ExactPrint.annFollowingComments ann
++ (ExactPrint.annsDP ann >>= \case ++ (ExactPrint.annsDP ann >>= \case
(ExactPrint.AnnComment com, dp) -> [(com, dp)] (ExactPrint.AnnComment com, dp) -> [(com, dp)]
_ -> [] _ -> []
) )
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast = filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-- | True if there are any comments that are -- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND -- a) connected to any node below (in AST sense) the given node AND
@ -242,15 +235,16 @@ hasCommentsBetween
-> ToBriDocM Bool -> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast mAnn <- astAnn ast
let go1 [] = False let
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest go1 [] = False
go1 (_ : rest) = go1 rest go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go2 [] = False go1 (_ : rest) = go1 rest
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True go2 [] = False
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
go2 (_ : rest) = go2 rest go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 (_ : rest) = go2 rest
case mAnn of case mAnn of
Nothing -> pure False Nothing -> pure False
Just ann -> pure $ go1 $ ExactPrint.annsDP ann Just ann -> pure $ go1 $ ExactPrint.annsDP ann
-- | True if there are any comments that are connected to any node below (in AST -- | True if there are any comments that are connected to any node below (in AST
@ -260,7 +254,8 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST -- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node -- sense) the given node
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyRegularCommentsConnected
:: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast = hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast any isRegularComment <$> astConnectedComments ast
@ -297,7 +292,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case
hasAnnKeywordComment hasAnnKeywordComment
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
Nothing -> False Nothing -> False
Just ann -> any hasK (extractAllComments ann) Just ann -> any hasK (extractAllComments ann)
where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
@ -311,7 +306,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
where where
hasK (ExactPrint.Types.G x, _) = x == annKeyword hasK (ExactPrint.Types.G x, _) = x == annKeyword
hasK _ = False hasK _ = False
astAnn astAnn
:: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
@ -460,12 +455,10 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
deriving (Functor, Applicative, Monad) deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc = addAlternativeCond cond doc = when cond (addAlternative doc)
when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = addAlternative = CollectAltM . Writer.tell . (: [])
CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) = runFilteredAlternative (CollectAltM action) =
@ -482,7 +475,8 @@ docLines l = allocateNode . BDFLines =<< sequence l
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docCols sig l = allocateNode . BDFCols sig =<< sequence l docCols sig l = allocateNode . BDFCols sig =<< sequence l
docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAddBaseY
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -517,7 +511,8 @@ docAnnotationKW
-> Maybe AnnKeywordId -> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docAnnotationKW annKey kw bdm =
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP docMoveToKWDP
:: AnnKey :: AnnKey
@ -569,7 +564,7 @@ docParenR :: ToBriDocM BriDocNumbered
docParenR = docLit $ Text.pack ")" docParenR = docLit $ Text.pack ")"
docParenHashLSep :: ToBriDocM BriDocNumbered docParenHashLSep :: ToBriDocM BriDocNumbered
docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
docParenHashRSep :: ToBriDocM BriDocNumbered docParenHashRSep :: ToBriDocM BriDocNumbered
docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
@ -631,32 +626,26 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNodePrior ast bdm = do docWrapNodePrior ast bdm = do
bd <- bdm bd <- bdm
i1 <- allocNodeIndex i1 <- allocNodeIndex
return return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd
docWrapNodeRest ast bdm = do docWrapNodeRest ast bdm = do
bd <- bdm bd <- bdm
i2 <- allocNodeIndex i2 <- allocNodeIndex
return return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
$ (,) i2
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
docWrapNode ast bdms = case bdms of docWrapNode ast bdms = case bdms of
[] -> [] [] -> []
[bd] -> [docWrapNode ast bd] [bd] -> [docWrapNode ast bd]
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> (bd1 : bdR) | (bdN : bdM) <- reverse bdR ->
[docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
docWrapNodePrior ast bdms = case bdms of docWrapNodePrior ast bdms = case bdms of
[] -> [] [] -> []
[bd] -> [docWrapNodePrior ast bd] [bd] -> [docWrapNodePrior ast bd]
(bd1:bdR) -> docWrapNodePrior ast bd1 : bdR (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR
docWrapNodeRest ast bdms = case reverse bdms of docWrapNodeRest ast bdms = case reverse bdms of
[] -> [] [] -> []
(bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
docWrapNode ast bdsm = do docWrapNode ast bdsm = do
@ -666,25 +655,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
[bd] -> do [bd] -> do
bd' <- docWrapNode ast (return bd) bd' <- docWrapNode ast (return bd)
return [bd'] return [bd']
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> do (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ [bd1'] ++ reverse bdM ++ [bdN'] return $ [bd1'] ++ reverse bdM ++ [bdN']
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
docWrapNodePrior ast bdsm = do docWrapNodePrior ast bdsm = do
bds <- bdsm bds <- bdsm
case bds of case bds of
[] -> return [] [] -> return []
(bd1:bdR) -> do (bd1 : bdR) -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
return (bd1':bdR) return (bd1' : bdR)
docWrapNodeRest ast bdsm = do docWrapNodeRest ast bdsm = do
bds <- bdsm bds <- bdsm
case reverse bds of case reverse bds of
[] -> return [] [] -> return []
(bdN:bdR) -> do (bdN : bdR) -> do
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse (bdN':bdR) return $ reverse (bdN' : bdR)
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
docWrapNode ast bdsm = do docWrapNode ast bdsm = do
@ -697,7 +686,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
return $ Seq.singleton bd1' return $ Seq.singleton bd1'
bdM Seq.:> bdN -> do bdM Seq.:> bdN -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ (bd1' Seq.<| bdM) Seq.|> bdN' return $ (bd1' Seq.<| bdM) Seq.|> bdN'
docWrapNodePrior ast bdsm = do docWrapNodePrior ast bdsm = do
bds <- bdsm bds <- bdsm
@ -741,7 +730,7 @@ docPar
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docPar lineM indentedM = do docPar lineM indentedM = do
line <- lineM line <- lineM
indented <- indentedM indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented allocateNode $ BDFPar BrIndentNone line indented
@ -778,14 +767,15 @@ briDocMToPPM m = do
briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
briDocMToPPMInner m = do briDocMToPPMInner m = do
readers <- MultiRWSS.mGetRawR readers <- MultiRWSS.mGetRawR
let ((x, errs), debugs) = let
runIdentity ((x, errs), debugs) =
$ MultiRWSS.runMultiRWSTNil runIdentity
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1) $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiReaders readers $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ m $ MultiRWSS.withMultiWriterAW
$ m
pure (x, errs, debugs) pure (x, errs, debugs)
docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)

394
source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

@ -3,26 +3,19 @@
module Language.Haskell.Brittany.Internal.Layouters.DataDecl where module Language.Haskell.Brittany.Internal.Layouters.DataDecl where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import GHC (GenLocated(L), Located)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( Located, GenLocated(L) )
import qualified GHC import qualified GHC
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Layouters.Type 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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
layoutDataDecl layoutDataDecl
:: Located (TyClDecl GhcPs) :: Located (TyClDecl GhcPs)
@ -32,28 +25,29 @@ layoutDataDecl
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- newtype MyType a b = MyType .. -- newtype MyType a b = MyType ..
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> case cons of
docWrapNode ltycl $ do (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
nameStr <- lrdrNameToTextAnn name -> docWrapNode ltycl $ do
consNameStr <- lrdrNameToTextAnn consName nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs consNameStr <- lrdrNameToTextAnn consName
-- headDoc <- fmap return $ docSeq tyVarLine <- return <$> createBndrDoc bndrs
-- [ appSep $ docLitS "newtype") -- headDoc <- fmap return $ docSeq
-- , appSep $ docLit nameStr -- [ appSep $ docLitS "newtype")
-- , appSep tyVarLine -- , appSep $ docLit nameStr
-- ] -- , appSep tyVarLine
rhsDoc <- return <$> createDetailsDoc consNameStr details -- ]
createDerivingPar mDerivs $ docSeq rhsDoc <- return <$> createDetailsDoc consNameStr details
[ appSep $ docLitS "newtype" createDerivingPar mDerivs $ docSeq
, appSep $ docLit nameStr [ appSep $ docLitS "newtype"
, appSep tyVarLine , appSep $ docLit nameStr
, docSeparator , appSep tyVarLine
, docLitS "=" , docSeparator
, docSeparator , docLitS "="
, rhsDoc , docSeparator
] , rhsDoc
_ -> briDocByExactNoComment ltycl ]
_ -> briDocByExactNoComment ltycl
-- data MyData a b -- data MyData a b
@ -61,8 +55,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
docWrapNode ltycl $ do docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, lhsContextDoc , lhsContextDoc
@ -74,32 +68,36 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData = MyData { .. } -- data MyData = MyData { .. }
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
case cons of case cons of
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
docWrapNode ltycl $ do -> docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
forallDocMay <- case createForallDoc qvars of forallDocMay <- case createForallDoc qvars of
Nothing -> pure Nothing Nothing -> pure Nothing
Just x -> Just . pure <$> x Just x -> Just . pure <$> x
rhsContextDocMay <- case mRhsContext of rhsContextDocMay <- case mRhsContext of
Nothing -> pure Nothing Nothing -> pure Nothing
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
rhsDoc <- return <$> createDetailsDoc consNameStr details rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <- fmap pure consDoc <-
fmap pure
$ docNonBottomSpacing $ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of $ case (forallDocMay, rhsContextDocMay) of
(Just forallDoc, Just rhsContextDoc) -> docLines (Just forallDoc, Just rhsContextDoc) -> docLines
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] [ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq , docSeq
[ docLitS "." [ docLitS "."
, docSeparator , docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] , docSetBaseY
$ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
] ]
(Just forallDoc, Nothing) -> docLines (Just forallDoc, Nothing) -> docLines
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] [ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq [docLitS ".", docSeparator, rhsDoc] , docSeq [docLitS ".", docSeparator, rhsDoc]
] ]
(Nothing, Just rhsContextDoc) -> docSeq (Nothing, Just rhsContextDoc) -> docSeq
@ -107,12 +105,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSeparator , docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
(Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] (Nothing, Nothing) ->
docSeq [docLitS "=", docSeparator, rhsDoc]
createDerivingPar mDerivs $ docAlt createDerivingPar mDerivs $ docAlt
[ -- data D = forall a . Show a => D a [ -- data D = forall a . Show a => D a
docSeq docSeq
[ docNodeAnnKW ltycl (Just GHC.AnnData) [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline $ lhsContextDoc , docForceSingleline $ lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -124,12 +122,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSetIndentLevel $ docSeq , docSetIndentLevel $ docSeq
[ case forallDocMay of [ case forallDocMay of
Nothing -> docEmpty Nothing -> docEmpty
Just forallDoc -> docSeq Just forallDoc ->
[ docForceSingleline forallDoc docSeq
, docSeparator [ docForceSingleline forallDoc
, docLitS "." , docSeparator
, docSeparator , docLitS "."
] , docSeparator
]
, maybe docEmpty docForceSingleline rhsContextDocMay , maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc , rhsDoc
] ]
@ -137,26 +136,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, -- data D , -- data D
-- = forall a . Show a => D a -- = forall a . Show a => D a
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
( docNodeAnnKW ltycl (Just GHC.AnnData) (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
, tyVarLine , tyVarLine
] ]
) )
( docSeq (docSeq
[ docLitS "=" [ docLitS "="
, docSeparator , docSeparator
, docSetIndentLevel $ docSeq , docSetIndentLevel $ docSeq
[ case forallDocMay of [ case forallDocMay of
Nothing -> docEmpty Nothing -> docEmpty
Just forallDoc -> docSeq Just forallDoc ->
[ docForceSingleline forallDoc docSeq
, docSeparator [ docForceSingleline forallDoc
, docLitS "." , docSeparator
, docSeparator , docLitS "."
] , docSeparator
]
, maybe docEmpty docForceSingleline rhsContextDocMay , maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc , rhsDoc
] ]
@ -167,8 +166,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- . Show a => -- . Show a =>
-- D a -- D a
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
( docNodeAnnKW ltycl (Just GHC.AnnData) (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -189,13 +187,10 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- hurt. -- hurt.
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
(docLitS "data") (docLitS "data")
( docLines (docLines
[ lhsContextDoc [ lhsContextDoc
, docNodeAnnKW ltycl (Just GHC.AnnData) , docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq $ docSeq [appSep $ docLit nameStr, tyVarLine]
[ appSep $ docLit nameStr
, tyVarLine
]
, consDoc , consDoc
] ]
) )
@ -209,20 +204,20 @@ createContextDoc [] = docEmpty
createContextDoc [t] = createContextDoc [t] =
docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
createContextDoc (t1 : tR) = do createContextDoc (t1 : tR) = do
t1Doc <- docSharedWrapper layoutType t1 t1Doc <- docSharedWrapper layoutType t1
tRDocs <- tR `forM` docSharedWrapper layoutType tRDocs <- tR `forM` docSharedWrapper layoutType
docAlt docAlt
[ docSeq [ docSeq
[ docLitS "(" [ docLitS "("
, docForceSingleline $ docSeq $ List.intersperse docCommaSep , docForceSingleline $ docSeq $ List.intersperse
(t1Doc : tRDocs) docCommaSep
(t1Doc : tRDocs)
, docLitS ") =>" , docLitS ") =>"
, docSeparator , docSeparator
] ]
, docLines $ join , docLines $ join
[ [docSeq [docLitS "(", docSeparator, t1Doc]] [ [docSeq [docLitS "(", docSeparator, t1Doc]]
, tRDocs , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
<&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
, [docLitS ") =>", docSeparator] , [docLitS ") =>", docSeparator]
] ]
] ]
@ -234,20 +229,18 @@ createBndrDoc bs = do
(L _ (KindedTyVar _ _ext lrdrName kind)) -> do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d) return $ (lrdrNameToText lrdrName, Just $ d)
docSeq docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
$ List.intersperse docSeparator case mKind of
$ tyVarDocs Nothing -> docLit vname
<&> \(vname, mKind) -> case mKind of Just kind -> docSeq
Nothing -> docLit vname [ docLitS "("
Just kind -> docSeq , docLit vname
[ docLitS "(" , docSeparator
, docLit vname , docLitS "::"
, docSeparator , docSeparator
, docLitS "::" , kind
, docSeparator , docLitS ")"
, kind ]
, docLitS ")"
]
createDerivingPar createDerivingPar
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -256,48 +249,47 @@ createDerivingPar derivs mainDoc = do
(L _ []) -> mainDoc (L _ []) -> mainDoc
(L _ types) -> (L _ types) ->
docPar mainDoc docPar mainDoc
$ docEnsureIndent BrIndentRegular $ docEnsureIndent BrIndentRegular
$ docLines $ docLines
$ docWrapNode derivs $ docWrapNode derivs
$ derivingClauseDoc $ derivingClauseDoc
<$> types <$> types
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) =
(L _ []) -> docSeq [] case types of
(L _ ts) -> (L _ []) -> docSeq []
let (L _ ts) ->
tsLength = length ts let
whenMoreThan1Type val = tsLength = length ts
if tsLength > 1 then docLitS val else docLitS "" whenMoreThan1Type val =
(lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy if tsLength > 1 then docLitS val else docLitS ""
in (lhsStrategy, rhsStrategy) =
docSeq maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
in docSeq
[ docDeriving [ docDeriving
, docWrapNodePrior types $ lhsStrategy , docWrapNodePrior types $ lhsStrategy
, docSeparator , docSeparator
, whenMoreThan1Type "(" , whenMoreThan1Type "("
, docWrapNodeRest types , docWrapNodeRest types
$ docSeq $ docSeq
$ List.intersperse docCommaSep $ List.intersperse docCommaSep
$ ts <&> \case $ ts
HsIB _ t -> layoutType t <&> \case
HsIB _ t -> layoutType t
, whenMoreThan1Type ")" , whenMoreThan1Type ")"
, rhsStrategy , rhsStrategy
] ]
where where
strategyLeftRight = \case strategyLeftRight = \case
(L _ StockStrategy ) -> (docLitS " stock", docEmpty) (L _ StockStrategy) -> (docLitS " stock", docEmpty)
(L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)
(L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)
lVia@(L _ (ViaStrategy viaTypes) ) -> lVia@(L _ (ViaStrategy viaTypes)) ->
( docEmpty ( docEmpty
, case viaTypes of , case viaTypes of
HsIB _ext t -> docSeq HsIB _ext t -> docSeq
[ docWrapNode lVia $ docLitS " via" [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
, docSeparator
, layoutType t
]
) )
docDeriving :: ToBriDocM BriDocNumbered docDeriving :: ToBriDocM BriDocNumbered
@ -307,21 +299,25 @@ createDetailsDoc
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of createDetailsDoc consNameStr details = case details of
PrefixCon args -> do PrefixCon args -> do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <-
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
singleLine = docSeq singleLine = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
, docForceSingleline , docForceSingleline
$ docSeq $ docSeq
$ List.intersperse docSeparator $ List.intersperse docSeparator
$ fmap hsScaledThing args <&> layoutType $ fmap hsScaledThing args
<&> layoutType
] ]
leftIndented = docSetParSpacing leftIndented =
. docAddBaseY BrIndentRegular docSetParSpacing
. docPar (docLit consNameStr) . docAddBaseY BrIndentRegular
. docLines . docPar (docLit consNameStr)
$ layoutType <$> fmap hsScaledThing args . docLines
$ layoutType
<$> fmap hsScaledThing args
multiAppended = docSeq multiAppended = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
@ -331,79 +327,80 @@ createDetailsDoc consNameStr details = case details of
(docLit consNameStr) (docLit consNameStr)
(docLines $ layoutType <$> fmap hsScaledThing args) (docLines $ layoutType <$> fmap hsScaledThing args)
case indentPolicy of case indentPolicy of
IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyLeft -> docAlt [singleLine, leftIndented]
IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]
IndentPolicyFree -> IndentPolicyFree ->
docAlt [singleLine, multiAppended, multiIndented, leftIndented] docAlt [singleLine, multiAppended, multiIndented, leftIndented]
RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] RecCon (L _ []) ->
RecCon lRec@(L _ fields@(_:_)) -> do docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
RecCon lRec@(L _ fields@(_ : _)) -> do
let ((fName1, fType1) : fDocR) = mkFieldDocs fields let ((fName1, fType1) : fDocR) = mkFieldDocs fields
-- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
let allowSingleline = False let allowSingleline = False
docAddBaseY BrIndentRegular docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
$ runFilteredAlternative
$ do
-- single-line: { i :: Int, b :: Bool } -- single-line: { i :: Int, b :: Bool }
addAlternativeCond allowSingleline $ docSeq addAlternativeCond allowSingleline $ docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
, docWrapNodePrior lRec $ docLitS "{" , docWrapNodePrior lRec $ docLitS "{"
, docSeparator , docSeparator
, docWrapNodeRest lRec , docWrapNodeRest lRec
$ docForceSingleline $ docForceSingleline
$ docSeq $ docSeq
$ join $ join
$ [fName1, docSeparator, docLitS "::", docSeparator, fType1] $ [fName1, docSeparator, docLitS "::", docSeparator, fType1]
: [ [ docLitS "," : [ [ docLitS ","
, docSeparator , docSeparator
, fName , fName
, docSeparator , docSeparator
, docLitS "::" , docLitS "::"
, docSeparator , docSeparator
, fType , fType
] ]
| (fName, fType) <- fDocR | (fName, fType) <- fDocR
]
, docSeparator
, docLitS "}"
] ]
addAlternative $ docPar , docSeparator
(docLit consNameStr) , docLitS "}"
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines ]
[ docAlt addAlternative $ docPar
[ docCols ColRecDecl (docLit consNameStr)
[ appSep (docLitS "{") (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
, appSep $ docForceSingleline fName1 [ docAlt
[ docCols
ColRecDecl
[ appSep (docLitS "{")
, appSep $ docForceSingleline fName1
, docSeq [docLitS "::", docSeparator]
, docForceSingleline $ fType1
]
, docSeq
[ docLitS "{"
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1
(docSeq [docLitS "::", docSeparator, fType1])
]
]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
docAlt
[ docCols
ColRecDecl
[ docCommaSep
, appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator] , docSeq [docLitS "::", docSeparator]
, docForceSingleline $ fType1 , docForceSingleline fType
] ]
, docSeq , docSeq
[ docLitS "{" [ docLitS ","
, docSeparator , docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1 fName
(docSeq [docLitS "::", docSeparator, fType1]) (docSeq [docLitS "::", docSeparator, fType])
] ]
] ]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> , docLitS "}"
docAlt ]
[ docCols ColRecDecl )
[ docCommaSep
, appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator]
, docForceSingleline fType
]
, docSeq
[ docLitS ","
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName
(docSeq [docLitS "::", docSeparator, fType])
]
]
, docLitS "}"
]
)
InfixCon arg1 arg2 -> docSeq InfixCon arg1 arg2 -> docSeq
[ layoutType $ hsScaledThing arg1 [ layoutType $ hsScaledThing arg1
, docSeparator , docSeparator
@ -418,10 +415,11 @@ createDetailsDoc consNameStr details = case details of
mkFieldDocs = fmap $ \lField -> case lField of mkFieldDocs = fmap $ \lField -> case lField of
L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc
createForallDoc [] = Nothing :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
createForallDoc lhsTyVarBndrs = Just $ docSeq createForallDoc [] = Nothing
[docLitS "forall ", createBndrDoc lhsTyVarBndrs] createForallDoc lhsTyVarBndrs =
Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createNamesAndTypeDoc createNamesAndTypeDoc
:: Data.Data.Data ast :: Data.Data.Data ast
@ -431,12 +429,8 @@ createNamesAndTypeDoc
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t = createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
[ docSeq [ docSeq $ List.intersperse docCommaSep $ names <&> \case
$ List.intersperse docCommaSep L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName
$ names
<&> \case
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
] ]
, docWrapNodeRest lField $ layoutType t , docWrapNodeRest lField $ layoutType t
) )

992
source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

13
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
View File

@ -2,20 +2,11 @@
module Language.Haskell.Brittany.Internal.Layouters.Expr where module Language.Haskell.Brittany.Internal.Layouters.Expr where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import GHC.Hs
layoutExpr :: ToBriDoc HsExpr layoutExpr :: ToBriDoc HsExpr
-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc :: HsLit GhcPs -> BriDocFInt
overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt

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

@ -4,26 +4,22 @@
module Language.Haskell.Brittany.Internal.Layouters.IE where module Language.Haskell.Brittany.Internal.Layouters.IE where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Text as Text 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 qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import GHC ( unLoc
, GenLocated(L)
, moduleNameString
, AnnKeywordId(..)
, Located
, ModuleName
)
import GHC.Hs
import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> Located name prepareName :: LIEWrappedName name -> Located name
prepareName = ieLWrappedName prepareName = ieLWrappedName
@ -37,36 +33,41 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x _ ns _ -> do IEThingWith _ x _ ns _ -> do
hasComments <- orM hasComments <- orM
( hasCommentsBetween lie AnnOpenP AnnCloseP (hasCommentsBetween lie AnnOpenP AnnCloseP
: hasAnyCommentsBelow x : hasAnyCommentsBelow x
: map hasAnyCommentsBelow ns : map hasAnyCommentsBelow ns
) )
let sortedNs = List.sortOn wrappedNameToText ns let sortedNs = List.sortOn wrappedNameToText ns
runFilteredAlternative $ do runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [layoutWrapped lie x, docLit $ Text.pack "("] $ [layoutWrapped lie x, docLit $ Text.pack "("]
++ intersperse docCommaSep (map nameDoc sortedNs) ++ intersperse docCommaSep (map nameDoc sortedNs)
++ [docParenR] ++ [docParenR]
addAlternative addAlternative
$ docWrapNodeRest lie $ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
(layoutWrapped lie x)
(layoutItems (splitFirstLast sortedNs))
where where
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty = docSetBaseY $ docLines layoutItems FirstLastEmpty = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]
, docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
, docParenR
]
layoutItems (FirstLast n1 nMs nN) = layoutItems (FirstLast n1 nMs nN) =
docSetBaseY docSetBaseY
$ docLines $ docLines
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs ++ map layoutItem nMs
++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] ++ [ docSeq
[docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
IEModuleContents _ n -> docSeq IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module" [ docLit $ Text.pack "module"
, docSeparator , docSeparator
@ -75,7 +76,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
_ -> docEmpty _ -> docEmpty
where where
layoutWrapped _ = \case layoutWrapped _ = \case
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
L _ (IEPattern n) -> do L _ (IEPattern n) -> do
name <- lrdrNameToTextAnn n name <- lrdrNameToTextAnn n
docLit $ Text.pack "pattern " <> name docLit $ Text.pack "pattern " <> name
@ -92,33 +93,36 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- handling of the resulting list. Adding parens is -- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive -- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs layoutAnnAndSepLLIEs
:: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] :: SortItemsFlag
-> Located [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie] let makeIENode ie = docSeq [docCommaSep, ie]
let sortedLies = let
[ items sortedLies =
| group <- Data.List.Extra.groupOn lieToText [ items
$ List.sortOn lieToText lies | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
, items <- mergeGroup group , items <- mergeGroup group
] ]
let ieDocs = fmap layoutIE $ case shouldSort of let
ShouldSortItems -> sortedLies ieDocs = fmap layoutIE $ case shouldSort of
KeepItemsUnsorted -> lies ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies
ieCommaDocs <- ieCommaDocs <-
docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
FirstLastEmpty -> [] FirstLastEmpty -> []
FirstLastSingleton ie -> [ie] FirstLastSingleton ie -> [ie]
FirstLast ie1 ieMs ieN -> FirstLast ie1 ieMs ieN ->
[ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
pure $ fmap pure ieCommaDocs -- returned shared nodes pure $ fmap pure ieCommaDocs -- returned shared nodes
where where
mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
mergeGroup [] = [] mergeGroup [] = []
mergeGroup items@[_] = items mergeGroup items@[_] = items
mergeGroup items = if mergeGroup items = if
| all isProperIEThing items -> [List.foldl1' thingFolder items] | all isProperIEThing items -> [List.foldl1' thingFolder items]
| all isIEVar items -> [List.foldl1' thingFolder items] | all isIEVar items -> [List.foldl1' thingFolder items]
| otherwise -> items | otherwise -> items
-- proper means that if it is a ThingWith, it does not contain a wildcard -- 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 -- (because I don't know what a wildcard means if it is not already a
-- IEThingAll). -- IEThingAll).
@ -131,21 +135,22 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
isIEVar :: LIE GhcPs -> Bool isIEVar :: LIE GhcPs -> Bool
isIEVar = \case isIEVar = \case
L _ IEVar{} -> True L _ IEVar{} -> True
_ -> False _ -> False
thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
thingFolder l1@(L _ IEVar{} ) _ = l1 thingFolder l1@(L _ IEVar{}) _ = l1
thingFolder l1@(L _ IEThingAll{}) _ = l1 thingFolder l1@(L _ IEThingAll{}) _ = l1
thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 ( L _ IEThingAbs{}) = l1 thingFolder l1 (L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2 thingFolder (L _ IEThingAbs{}) l2 = l2
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
= L = L
l l
(IEThingWith x (IEThingWith
wn x
NoIEWildcard wn
(consItems1 ++ consItems2) NoIEWildcard
(fieldLbls1 ++ fieldLbls2) (consItems1 ++ consItems2)
(fieldLbls1 ++ fieldLbls2)
) )
thingFolder _ _ = thingFolder _ _ =
error "thingFolder should be exhaustive because we have a guard above" error "thingFolder should be exhaustive because we have a guard above"
@ -164,9 +169,10 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- () -- no comments -- () -- no comments
-- ( -- a comment -- ( -- a comment
-- ) -- )
layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
runFilteredAlternative $ case ieDs of runFilteredAlternative $ case ieDs of
[] -> do [] -> do
@ -176,14 +182,14 @@ layoutLLIEs enableSingleline shouldSort llies = do
docParenR docParenR
(ieDsH : ieDsT) -> do (ieDsH : ieDsT) -> do
addAlternativeCond (not hasComments && enableSingleline) addAlternativeCond (not hasComments && enableSingleline)
$ docSeq $ docSeq
$ [docLit (Text.pack "(")] $ [docLit (Text.pack "(")]
++ (docForceSingleline <$> ieDs) ++ (docForceSingleline <$> ieDs)
++ [docParenR] ++ [docParenR]
addAlternative addAlternative
$ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
$ docLines $ docLines
$ ieDsT $ ieDsT
++ [docParenR] ++ [docParenR]
-- | Returns a "fingerprint string", not a full text representation, nor even -- | Returns a "fingerprint string", not a full text representation, nor even
@ -191,26 +197,27 @@ layoutLLIEs enableSingleline shouldSort llies = do
-- Used for sorting, not for printing the formatter's output source code. -- Used for sorting, not for printing the formatter's output source code.
wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case wrappedNameToText = \case
L _ (IEName n) -> lrdrNameToText n L _ (IEName n) -> lrdrNameToText n
L _ (IEPattern n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n
L _ (IEType n) -> lrdrNameToText n L _ (IEType n) -> lrdrNameToText n
-- | Returns a "fingerprint string", not a full text representation, nor even -- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node. -- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code. -- Used for sorting, not for printing the formatter's output source code.
lieToText :: LIE GhcPs -> Text lieToText :: LIE GhcPs -> Text
lieToText = \case lieToText = \case
L _ (IEVar _ wn ) -> wrappedNameToText wn L _ (IEVar _ wn) -> wrappedNameToText wn
L _ (IEThingAbs _ wn ) -> wrappedNameToText wn L _ (IEThingAbs _ wn) -> wrappedNameToText wn
L _ (IEThingAll _ wn ) -> wrappedNameToText wn L _ (IEThingAll _ wn) -> wrappedNameToText wn
L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports! -- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some -- Need to check, and either put them at the top (for module) or do some
-- other clever thing. -- other clever thing.
L _ (IEModuleContents _ n) -> moduleNameToText n L _ (IEModuleContents _ n) -> moduleNameToText n
L _ IEGroup{} -> Text.pack "@IEGroup" L _ IEGroup{} -> Text.pack "@IEGroup"
L _ IEDoc{} -> Text.pack "@IEDoc" L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed" L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where where
moduleNameToText :: Located ModuleName -> Text moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)

201
source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs
View File

@ -2,26 +2,18 @@
module Language.Haskell.Brittany.Internal.Layouters.Import where module Language.Haskell.Brittany.Internal.Layouters.Import where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L), Located, moduleNameString, unLoc)
import Language.Haskell.Brittany.Internal.Types import GHC.Hs
import Language.Haskell.Brittany.Internal.LayouterBasics import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( unLoc
, GenLocated(L)
, moduleNameString
, Located
)
import GHC.Hs
import GHC.Types.Basic
import GHC.Unit.Types (IsBootInterface(..)) 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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
prepPkg :: SourceText -> String prepPkg :: SourceText -> String
prepPkg rawN = case rawN of prepPkg rawN = case rawN of
@ -36,111 +28,132 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
layoutImport importD = case importD of layoutImport importD = case importD of
ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do
importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack
importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack importAsCol <-
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
indentPolicy <-
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
compact = indentPolicy /= IndentPolicyFree compact = indentPolicy /= IndentPolicyFree
modNameT = Text.pack $ moduleNameString modName modNameT = Text.pack $ moduleNameString modName
pkgNameT = Text.pack . prepPkg . sl_st <$> pkg pkgNameT = Text.pack . prepPkg . sl_st <$> pkg
masT = Text.pack . moduleNameString . prepModName <$> mas masT = Text.pack . moduleNameString . prepModName <$> mas
hiding = maybe False fst mllies hiding = maybe False fst mllies
minQLength = length "import qualified " minQLength = length "import qualified "
qLengthReal = qLengthReal =
let qualifiedPart = if q /= NotQualified then length "qualified " else 0 let
safePart = if safe then length "safe " else 0 qualifiedPart = if q /= NotQualified then length "qualified " else 0
pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT safePart = if safe then length "safe " else 0
srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT
in length "import " + srcPart + safePart + qualifiedPart + pkgPart srcPart = case src of
qLength = max minQLength qLengthReal IsBoot -> length "{-# SOURCE #-} "
NotBoot -> 0
in length "import " + srcPart + safePart + qualifiedPart + pkgPart
qLength = max minQLength qLengthReal
-- Cost in columns of importColumn -- Cost in columns of importColumn
asCost = length "as " asCost = length "as "
hidingParenCost = if hiding then length "hiding ( " else length "( " hidingParenCost = if hiding then length "hiding ( " else length "( "
nameCost = Text.length modNameT + qLength nameCost = Text.length modNameT + qLength
importQualifiers = docSeq importQualifiers = docSeq
[ appSep $ docLit $ Text.pack "import" [ appSep $ docLit $ Text.pack "import"
, case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } , case src of
IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"
NotBoot -> docEmpty
, if safe then appSep $ docLit $ Text.pack "safe" else docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty
, if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty , if q /= NotQualified
then appSep $ docLit $ Text.pack "qualified"
else docEmpty
, maybe docEmpty (appSep . docLit) pkgNameT , maybe docEmpty (appSep . docLit) pkgNameT
] ]
indentName = indentName =
if compact then id else docEnsureIndent (BrIndentSpecial qLength) if compact then id else docEnsureIndent (BrIndentSpecial qLength)
modNameD = modNameD = indentName $ appSep $ docLit modNameT
indentName $ appSep $ docLit modNameT hidDocCol =
hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 if hiding then importCol - hidingParenCost else importCol - 2
hidDocColDiff = importCol - 2 - hidDocCol hidDocColDiff = importCol - 2 - hidDocCol
hidDoc = if hiding hidDoc =
then appSep $ docLit $ Text.pack "hiding" if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty
else docEmpty
importHead = docSeq [importQualifiers, modNameD] importHead = docSeq [importQualifiers, modNameD]
bindingsD = case mllies of bindingsD = case mllies of
Nothing -> docEmpty Nothing -> docEmpty
Just (_, llies) -> do Just (_, llies) -> do
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
if compact if compact
then docAlt then docAlt
[ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] [ docSeq
, let makeParIfHiding = if hiding [ hidDoc
, docForceSingleline $ layoutLLIEs True ShouldSortItems llies
]
, let
makeParIfHiding = if hiding
then docAddBaseY BrIndentRegular . docPar hidDoc then docAddBaseY BrIndentRegular . docPar hidDoc
else id else id
in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)
] ]
else do else do
ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies
docWrapNodeRest llies docWrapNodeRest llies
$ docEnsureIndent (BrIndentSpecial hidDocCol) $ docEnsureIndent (BrIndentSpecial hidDocCol)
$ case ieDs of $ case ieDs of
-- ..[hiding].( ) -- ..[hiding].( )
[] -> if hasComments [] -> if hasComments
then docPar then docPar
(docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) (docSeq
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) [hidDoc, docParenLSep, docWrapNode llies docEmpty]
else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] )
-- ..[hiding].( b ) (docEnsureIndent
[ieD] -> runFilteredAlternative $ do (BrIndentSpecial hidDocColDiff)
addAlternativeCond (not hasComments) docParenR
$ docSeq )
[ hidDoc else docSeq
, docParenLSep [hidDoc, docParenLSep, docSeparator, docParenR]
, docForceSingleline ieD -- ..[hiding].( b )
, docSeparator [ieD] -> runFilteredAlternative $ do
, docParenR addAlternativeCond (not hasComments)
] $ docSeq
addAlternative $ docPar [ hidDoc
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) , docParenLSep
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) , docForceSingleline ieD
-- ..[hiding].( b , docSeparator
-- , b' , docParenR
-- ) ]
(ieD:ieDs') -> addAlternative $ docPar
docPar (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]
(docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) )
( docEnsureIndent (BrIndentSpecial hidDocColDiff) (docEnsureIndent
$ docLines (BrIndentSpecial hidDocColDiff)
$ ieDs' docParenR
++ [docParenR] )
) -- ..[hiding].( b
-- , b'
-- )
(ieD : ieDs') -> docPar
(docSeq
[hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]
)
(docEnsureIndent (BrIndentSpecial hidDocColDiff)
$ docLines
$ ieDs'
++ [docParenR]
)
makeAsDoc asT = makeAsDoc asT =
docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT]
if compact if compact
then then
let asDoc = maybe docEmpty makeAsDoc masT let asDoc = maybe docEmpty makeAsDoc masT
in docAlt in
[ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] docAlt
, docAddBaseY BrIndentRegular $ [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]
docPar (docSeq [importHead, asDoc]) bindingsD , docAddBaseY BrIndentRegular
] $ docPar (docSeq [importHead, asDoc]) bindingsD
else ]
case masT of else case masT of
Just n -> if enoughRoom Just n -> if enoughRoom
then docLines then docLines [docSeq [importHead, asDoc], bindingsD]
[ docSeq [importHead, asDoc], bindingsD]
else docLines [importHead, asDoc, bindingsD] else docLines [importHead, asDoc, bindingsD]
where where
enoughRoom = nameCost < importAsCol - asCost enoughRoom = nameCost < importAsCol - asCost
asDoc = asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost))
docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) $ makeAsDoc n
$ makeAsDoc n
Nothing -> if enoughRoom Nothing -> if enoughRoom
then docSeq [importHead, bindingsD] then docSeq [importHead, bindingsD]
else docLines [importHead, bindingsD] else docLines [importHead, bindingsD]

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

@ -3,34 +3,27 @@
module Language.Haskell.Brittany.Internal.Layouters.Module where module Language.Haskell.Brittany.Internal.Layouters.Module where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)
import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..)) import Language.Haskell.GHC.ExactPrint as ExactPrint
import GHC.Hs import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint as ExactPrint (DeltaPos(..), commentContents, deltaRow)
import Language.Haskell.GHC.ExactPrint.Types
( DeltaPos(..)
, deltaRow
, commentContents
)
layoutModule :: ToBriDoc' HsModule layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of layoutModule lmod@(L _ mod') = case mod' of
-- Implicit module Main -- Implicit module Main
HsModule _ Nothing _ imports _ _ _ -> do HsModule _ Nothing _ imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
@ -41,43 +34,38 @@ layoutModule lmod@(L _ mod') = case mod' of
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports -- sortedImports <- sortImports imports
let tn = Text.pack $ moduleNameString $ unLoc n let tn = Text.pack $ moduleNameString $ unLoc n
allowSingleLineExportList <- mAsk allowSingleLineExportList <-
<&> _conf_layout mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
.> _lconfig_allowSingleLineExportList
.> confUnpack
-- the config should not prevent single-line layout when there is no -- the config should not prevent single-line layout when there is no
-- export list -- export list
let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les let
allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
docLines docLines
$ docSeq $ docSeq
[ docNodeAnnKW lmod Nothing docEmpty [ docNodeAnnKW lmod Nothing docEmpty
-- A pseudo node that serves merely to force documentation -- A pseudo node that serves merely to force documentation
-- before the node -- before the node
, docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do
addAlternativeCond allowSingleLine $ addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq
docForceSingleline [ appSep $ docLit $ Text.pack "module"
$ docSeq , appSep $ docLit tn
[ appSep $ docLit $ Text.pack "module" , docWrapNode lmod $ appSep $ case les of
, appSep $ docLit tn Nothing -> docEmpty
, docWrapNode lmod $ appSep $ case les of Just x -> layoutLLIEs True KeepItemsUnsorted x
Nothing -> docEmpty , docSeparator
Just x -> layoutLLIEs True KeepItemsUnsorted x , docLit $ Text.pack "where"
, docSeparator ]
, docLit $ Text.pack "where" addAlternative $ docLines
]
addAlternative
$ docLines
[ docAddBaseY BrIndentRegular $ docPar [ docAddBaseY BrIndentRegular $ docPar
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn] (docSeq [appSep $ docLit $ Text.pack "module", docLit tn])
) (docSeq
(docSeq [ [ docWrapNode lmod $ case les of
docWrapNode lmod $ case les of Nothing -> docEmpty
Nothing -> docEmpty Just x -> layoutLLIEs False KeepItemsUnsorted x
Just x -> layoutLLIEs False KeepItemsUnsorted x , docSeparator
, docSeparator , docLit $ Text.pack "where"
, docLit $ Text.pack "where" ]
] )
)
] ]
] ]
: (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]
@ -89,7 +77,7 @@ data CommentedImport
instance Show CommentedImport where instance Show CommentedImport where
show = \case show = \case
EmptyLine -> "EmptyLine" EmptyLine -> "EmptyLine"
IndependentComment _ -> "IndependentComment" IndependentComment _ -> "IndependentComment"
ImportStatement r -> ImportStatement r ->
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
@ -102,8 +90,9 @@ data ImportStatementRecord = ImportStatementRecord
} }
instance Show ImportStatementRecord where instance Show ImportStatementRecord where
show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show show r =
(length $ commentsAfter r) "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
transformToCommentedImport transformToCommentedImport
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
@ -121,10 +110,11 @@ transformToCommentedImport is = do
accumF accConnectedComm (annMay, decl) = case annMay of accumF accConnectedComm (annMay, decl) = case annMay of
Nothing -> Nothing ->
( [] ( []
, [ ImportStatement ImportStatementRecord { commentsBefore = [] , [ ImportStatement ImportStatementRecord
, commentsAfter = [] { commentsBefore = []
, importStatement = decl , commentsAfter = []
} , importStatement = decl
}
] ]
) )
Just ann -> Just ann ->
@ -136,7 +126,7 @@ transformToCommentedImport is = do
:: [(Comment, DeltaPos)] :: [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
-> ([CommentedImport], [(Comment, DeltaPos)], Int) -> ([CommentedImport], [(Comment, DeltaPos)], Int)
go acc [] = ([], acc, 0) go acc [] = ([], acc, 0)
go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
go acc ((c1, DP (y, x)) : xs) = go acc ((c1, DP (y, x)) : xs) =
@ -153,8 +143,8 @@ transformToCommentedImport is = do
, convertedIndependentComments , convertedIndependentComments
++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine
++ [ ImportStatement ImportStatementRecord ++ [ ImportStatement ImportStatementRecord
{ commentsBefore = beforeComments { commentsBefore = beforeComments
, commentsAfter = accConnectedComm , commentsAfter = accConnectedComm
, importStatement = decl , importStatement = decl
} }
] ]
@ -168,14 +158,14 @@ sortCommentedImports =
where where
unpackImports :: [CommentedImport] -> [CommentedImport] unpackImports :: [CommentedImport] -> [CommentedImport]
unpackImports xs = xs >>= \case unpackImports xs = xs >>= \case
l@EmptyLine -> [l] l@EmptyLine -> [l]
l@IndependentComment{} -> [l] l@IndependentComment{} -> [l]
ImportStatement r -> ImportStatement r ->
map IndependentComment (commentsBefore r) ++ [ImportStatement r] map IndependentComment (commentsBefore r) ++ [ImportStatement r]
mergeGroups mergeGroups
:: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]
mergeGroups xs = xs >>= \case mergeGroups xs = xs >>= \case
Left x -> [x] Left x -> [x]
Right y -> ImportStatement <$> y Right y -> ImportStatement <$> y
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
sortGroups = sortGroups =
@ -185,25 +175,23 @@ sortCommentedImports =
groupify cs = go [] cs groupify cs = go [] cs
where where
go [] = \case go [] = \case
(l@EmptyLine : rest) -> Left l : go [] rest (l@EmptyLine : rest) -> Left l : go [] rest
(l@IndependentComment{} : rest) -> Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : go [] rest
(ImportStatement r : rest) -> go [r] rest (ImportStatement r : rest) -> go [r] rest
[] -> [] [] -> []
go acc = \case go acc = \case
(l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest
(l@IndependentComment{} : rest) -> (l@IndependentComment{} : rest) ->
Left l : Right (reverse acc) : go [] rest Left l : Right (reverse acc) : go [] rest
(ImportStatement r : rest) -> go (r : acc) rest (ImportStatement r : rest) -> go (r : acc) rest
[] -> [Right (reverse acc)] [] -> [Right (reverse acc)]
commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
commentedImportsToDoc = \case commentedImportsToDoc = \case
EmptyLine -> docLitS "" EmptyLine -> docLitS ""
IndependentComment c -> commentToDoc c IndependentComment c -> commentToDoc c
ImportStatement r -> ImportStatement r -> docSeq
docSeq (layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
( layoutImport (importStatement r)
: map commentToDoc (commentsAfter r)
)
where where
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) commentToDoc (c, DP (_y, x)) =
docLitS (replicate x ' ' ++ commentContents c)

109
source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -3,28 +3,19 @@
module Language.Haskell.Brittany.Internal.Layouters.Pattern where module Language.Haskell.Brittany.Internal.Layouters.Pattern where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L), ol_val)
import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( GenLocated(L)
, ol_val
)
import GHC.Hs
import GHC.Types.Basic
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
-- | layouts patterns (inside function bindings, case alternatives, let -- | layouts patterns (inside function bindings, case alternatives, let
-- bindings or do notation). E.g. for input -- bindings or do notation). E.g. for input
@ -38,17 +29,15 @@ import Language.Haskell.Brittany.Internal.Layouters.Type
-- the different cases below. -- the different cases below.
layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr -- _ -> expr
VarPat _ n -> VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr -- abc -> expr
LitPat _ lit -> LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr -- 0 -> expr
ParPat _ inner -> do ParPat _ inner -> do
-- (nestedpat) -> expr -- (nestedpat) -> expr
left <- docLit $ Text.pack "(" left <- docLit $ Text.pack "("
right <- docLit $ Text.pack ")" right <- docLit $ Text.pack ")"
innerDocs <- colsWrapPat =<< layoutPat inner innerDocs <- colsWrapPat =<< layoutPat inner
return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right
@ -74,10 +63,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
then return <$> docLit nameDoc then return <$> docLit nameDoc
else do else do
x1 <- appSep (docLit nameDoc) x1 <- appSep (docLit nameDoc)
xR <- fmap Seq.fromList xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap
$ sequence colsWrapPat
$ spacifyDocs argDocs
$ fmap colsWrapPat argDocs
return $ x1 Seq.<| xR return $ x1 Seq.<| xR
ConPat _ lname (InfixCon left right) -> do ConPat _ lname (InfixCon left right) -> do
-- a :< b -> expr -- a :< b -> expr
@ -90,7 +78,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- Abc{} -> expr -- Abc{} -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
fmap Seq.singleton $ docLit $ t <> Text.pack "{}" fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do
-- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2 -- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname let t = lrdrNameToText lname
@ -103,37 +91,34 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
Seq.singleton <$> docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, docSeq $ List.intersperse docCommaSep , docSeq $ List.intersperse docCommaSep $ fds <&> \case
$ fds <&> \case (fieldName, Just fieldDoc) -> docSeq
(fieldName, Just fieldDoc) -> docSeq [ appSep $ docLit fieldName
[ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "="
, appSep $ docLit $ Text.pack "=" , fieldDoc >>= colsWrapPat
, fieldDoc >>= colsWrapPat ]
] (fieldName, Nothing) -> docLit fieldName
(fieldName, Nothing) -> docLit fieldName
, docSeparator , docSeparator
, docLit $ Text.pack "}" , docLit $ Text.pack "}"
] ]
ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
-- Abc { .. } -> expr -- Abc { .. } -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
Seq.singleton <$> docSeq Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"]
[ appSep $ docLit t ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti))))
, docLit $ Text.pack "{..}" | dotdoti == length fs -> do
]
ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do
-- Abc { a = locA, .. } -- Abc { a = locA, .. }
let t = lrdrNameToText lname 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 let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
else Just <$> docSharedWrapper layoutPat fPat else Just <$> docSharedWrapper layoutPat fPat
return (lrdrNameToText lnameF, fExpDoc) return (lrdrNameToText lnameF, fExpDoc)
Seq.singleton <$> docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, docSeq $ fds >>= \case , docSeq $ fds >>= \case
(fieldName, Just fieldDoc) -> (fieldName, Just fieldDoc) ->
[ appSep $ docLit fieldName [ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
@ -141,13 +126,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
, docCommaSep , docCommaSep
] ]
(fieldName, Nothing) -> [docLit fieldName, docCommaSep] (fieldName, Nothing) -> [docLit fieldName, docCommaSep]
, docLit $ Text.pack "..}" , docLit $ Text.pack "..}"
] ]
TuplePat _ args boxity -> do TuplePat _ args boxity -> do
-- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (nestedpat1, nestedpat2, nestedpat3) -> expr
-- (#nestedpat1, nestedpat2, nestedpat3#) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
case boxity of case boxity of
Boxed -> wrapPatListy args "()" docParenL docParenR Boxed -> wrapPatListy args "()" docParenL docParenR
Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep
AsPat _ asName asPat -> do AsPat _ asName asPat -> do
-- bind@nestedpat -> expr -- bind@nestedpat -> expr
@ -184,10 +169,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
wrapPatPrepend pat1 (docLit $ Text.pack "~") wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do NPat _ llit@(L _ ol) mNegative _ -> do
-- -13 -> expr -- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val
ol
negDoc <- docLit $ Text.pack "-" negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc] Just{} -> Seq.fromList [negDoc, litDoc]
Nothing -> Seq.singleton litDoc Nothing -> Seq.singleton litDoc
_ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
@ -196,9 +182,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend wrapPatPrepend
:: LPat GhcPs :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered)
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do wrapPatPrepend pat prepElem = do
patDocs <- layoutPat pat patDocs <- layoutPat pat
case Seq.viewl patDocs of case Seq.viewl patDocs of
@ -220,8 +204,5 @@ wrapPatListy elems both start end = do
x1 Seq.:< rest -> do x1 Seq.:< rest -> do
sDoc <- start sDoc <- start
eDoc <- end eDoc <- end
rest' <- rest `forM` \bd -> docSeq rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd]
[ docCommaSep
, return bd
]
return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

52
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
View File

@ -4,26 +4,19 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text 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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( GenLocated(L)
)
import GHC.Hs
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.Decl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do layoutStmt lstmt@(L _ stmt) = do
@ -53,12 +46,12 @@ layoutStmt lstmt@(L _ stmt) = do
] ]
] ]
LetStmt _ binds -> do LetStmt _ binds -> do
let isFree = indentPolicy == IndentPolicyFree let isFree = indentPolicy == IndentPolicyFree
let indentFourPlus = indentAmount >= 4 let indentFourPlus = indentAmount >= 4
layoutLocalBinds binds >>= \case layoutLocalBinds binds >>= \case
Nothing -> docLit $ Text.pack "let" Nothing -> docLit $ Text.pack "let"
-- i just tested the above, and it is indeed allowed. heh. -- i just tested the above, and it is indeed allowed. heh.
Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [] -> docLit $ Text.pack "let" -- this probably never happens
Just [bindDoc] -> docAlt Just [bindDoc] -> docAlt
[ -- let bind = expr [ -- let bind = expr
docCols docCols
@ -68,9 +61,10 @@ layoutStmt lstmt@(L _ stmt) = do
f = case indentPolicy of f = case indentPolicy of
IndentPolicyFree -> docSetBaseAndIndent IndentPolicyFree -> docSetBaseAndIndent
IndentPolicyLeft -> docForceSingleline IndentPolicyLeft -> docForceSingleline
IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent IndentPolicyMultiple
| otherwise -> docForceSingleline | indentFourPlus -> docSetBaseAndIndent
in f $ return bindDoc | otherwise -> docForceSingleline
in f $ return bindDoc
] ]
, -- let , -- let
-- bind = expr -- bind = expr
@ -84,10 +78,11 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (isFree || indentFourPlus) $ docSeq addAlternativeCond (isFree || indentFourPlus) $ docSeq
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, let f = if indentFourPlus , let
then docEnsureIndent BrIndentRegular f = if indentFourPlus
else docSetBaseAndIndent then docEnsureIndent BrIndentRegular
in f $ docLines $ return <$> bindDocs else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs
] ]
-- let -- let
-- aaa = expra -- aaa = expra
@ -95,8 +90,9 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (not indentFourPlus) addAlternativeCond (not indentFourPlus)
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "let") $ docPar
(docSetBaseAndIndent $ docLines $ return <$> bindDocs) (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1 -- rec stmt1
-- stmt2 -- stmt2

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

@ -2,14 +2,7 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import GHC.Hs
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))

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

@ -3,28 +3,18 @@
module Language.Haskell.Brittany.Internal.Layouters.Type where 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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Text as Text import Language.Haskell.Brittany.Internal.Types
import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Utils
( splitFirstLast
, FirstLastView(..)
)
import GHC ( GenLocated(L)
, AnnKeywordId (..)
)
import GHC.Hs
import GHC.Utils.Outputable ( ftext, showSDocUnsafe )
import GHC.Types.Basic
layoutType :: ToBriDoc HsType layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
@ -32,76 +22,66 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsTyVar _ promoted name -> do HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of case promoted of
IsPromoted -> docSeq IsPromoted ->
[ docSeparator docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
, docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t NotPromoted -> docWrapNode name $ docLit t
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2 typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let maybeForceML = case typ2 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ2 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
let let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt forallDoc = docAlt
[ let [ let open = docLit $ Text.pack "forall"
open = docLit $ Text.pack "forall" in docSeq ([open] ++ tyVarDocLineList)
in docSeq ([open]++tyVarDocLineList)
, docPar , docPar
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines (docLines $ tyVarDocs <&> \case
$ tyVarDocs <&> \case (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
(tname, Just doc) -> docEnsureIndent BrIndentRegular [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
$ docLines , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
[ docCols ColTyOpPrefix , docLit $ Text.pack ")"
[ docParenLSep ]
, docLit tname )
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
])
] ]
contextDoc = case cntxtDocs of contextDoc = case cntxtDocs of
[] -> docLit $ Text.pack "()" [] -> docLit $ Text.pack "()"
[x] -> x [x] -> x
_ -> docAlt _ -> docAlt
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep list =
$ docForceSingleline <$> cntxtDocs List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close]) in docSeq ([open] ++ list ++ [close])
, let , let
open = docCols ColTyOpPrefix open = docCols
[ docParenLSep ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs [ docParenLSep
] , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
docCols ColTyOpPrefix ColTyOpPrefix
[ docCommaSep [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
, docAddBaseY (BrIndentSpecial 2) cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
docAlt docAlt
-- :: forall a b c . (Foo a b c) => a b -> c -- :: forall a b c . (Foo a b c) => a b -> c
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else let else
let
open = docLit $ Text.pack "forall" open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . " close = docLit $ Text.pack " . "
in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])
, docForceSingleline contextDoc , docForceSingleline contextDoc
, docLit $ Text.pack " => " , docLit $ Text.pack " => "
, docForceSingleline typeDoc , docForceSingleline typeDoc
@ -111,75 +91,74 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b -- => a b
-- -> c -- -> c
, docPar , docPar
forallDoc forallDoc
( docLines (docLines
[ docCols ColTyOpPrefix [ docCols
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 3) [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
$ contextDoc , docAddBaseY (BrIndentSpecial 3) $ contextDoc
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
] ]
) , docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
]
)
] ]
HsForAllTy _ hsf typ2 -> do HsForAllTy _ hsf typ2 -> do
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- layoutType typ2 typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
let maybeForceML = case typ2 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ2 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
docAlt docAlt
-- forall x . x -- forall x . x
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else let else
let
open = docLit $ Text.pack "forall" open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . " close = docLit $ Text.pack " . "
in docSeq ([open]++tyVarDocLineList++[close]) in docSeq ([open] ++ tyVarDocLineList ++ [close])
, docForceSingleline $ return $ typeDoc , docForceSingleline $ return $ typeDoc
] ]
-- :: forall x -- :: forall x
-- . x -- . x
, docPar , docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
( docCols ColTyOpPrefix (docCols
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " ColTyOpPrefix
, maybeForceML $ return typeDoc [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
] , maybeForceML $ return typeDoc
) ]
)
-- :: forall -- :: forall
-- (x :: *) -- (x :: *)
-- . x -- . x
, docPar , docPar
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines (docLines
$ (tyVarDocs <&> \case $ (tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname (tname, Nothing) ->
(tname, Just doc) -> docEnsureIndent BrIndentRegular docEnsureIndent BrIndentRegular $ docLit tname
$ docLines (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
[ docParenLSep , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit tname , docLit $ Text.pack ")"
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
]
)
++[ docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
] ]
]
) )
++ [ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
]
)
] ]
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1 typeDoc <- docSharedWrapper layoutType typ1
@ -190,29 +169,27 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[x] -> x [x] -> x
_ -> docAlt _ -> docAlt
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep list =
$ docForceSingleline <$> cntxtDocs List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close]) in docSeq ([open] ++ list ++ [close])
, let , let
open = docCols ColTyOpPrefix open = docCols
[ docParenLSep ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) [ docParenLSep
$ head cntxtDocs , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
] ]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
docCols ColTyOpPrefix ColTyOpPrefix
[ docCommaSep [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
let maybeForceML = case typ1 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ1 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
docAlt docAlt
-- (Foo a b c) => a b -> c -- (Foo a b c) => a b -> c
[ docSeq [ docSeq
@ -224,37 +201,39 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b -- => a b
-- -> c -- -> c
, docPar , docPar
(docForceSingleline contextDoc) (docForceSingleline contextDoc)
( docCols ColTyOpPrefix (docCols
[ docLit $ Text.pack "=> " ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc [ docLit $ Text.pack "=> "
] , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
) ]
)
] ]
HsFunTy _ _ typ1 typ2 -> do HsFunTy _ _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2 typeDoc2 <- docSharedWrapper layoutType typ2
let maybeForceML = case typ2 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ2 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
hasComments <- hasAnyCommentsBelow ltype hasComments <- hasAnyCommentsBelow ltype
docAlt $ docAlt
[ docSeq $ [ docSeq
[ appSep $ docForceSingleline typeDoc1 [ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->" , appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
]
| not hasComments
] ]
| not hasComments ++ [ docPar
] ++ (docNodeAnnKW ltype Nothing typeDoc1)
[ docPar (docCols
(docNodeAnnKW ltype Nothing typeDoc1) ColTyOpPrefix
( docCols ColTyOpPrefix [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2
, docAddBaseY (BrIndentSpecial 3) ]
$ maybeForceML typeDoc2 )
] ]
)
]
HsParTy _ typ1 -> do HsParTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
@ -264,24 +243,28 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
, docPar , docPar
( docCols ColTyOpPrefix (docCols
[ docWrapNodeRest ltype $ docParenLSep ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 [ docWrapNodeRest ltype $ docParenLSep
]) , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
(docLit $ Text.pack ")") ]
)
(docLit $ Text.pack ")")
] ]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) let
gather list = \case gather
L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
final -> (final, list) gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1 let (typHead, typRest) = gather [typ2] typ1
docHead <- docSharedWrapper layoutType typHead docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt docAlt
[ docSeq [ docSeq
$ docForceSingleline docHead : (docRest >>= \d -> $ docForceSingleline docHead
[ docSeparator, docForceSingleline d ]) : (docRest >>= \d -> [docSeparator, docForceSingleline d])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
] ]
HsAppTy _ typ1 typ2 -> do HsAppTy _ typ1 typ2 -> do
@ -293,9 +276,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docSeparator , docSeparator
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
] ]
, docPar , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
] ]
HsListTy _ typ1 -> do HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
@ -306,51 +287,61 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
, docPar , docPar
( docCols ColTyOpPrefix (docCols
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ " ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
]) , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
(docLit $ Text.pack "]") ]
)
(docLit $ Text.pack "]")
] ]
HsTupleTy _ tupleSort typs -> case tupleSort of HsTupleTy _ tupleSort typs -> case tupleSort of
HsUnboxedTuple -> unboxed HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple HsBoxedTuple -> simple
HsConstraintTuple -> simple HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple
where where
unboxed = if null typs then error "brittany internal error: unboxed unit" unboxed = if null typs
else unboxedL then error "brittany internal error: unboxed unit"
else unboxedL
simple = if null typs then unitL else simpleL simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()" unitL = docLit $ Text.pack "()"
simpleL = do simpleL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let end = docLit $ Text.pack ")" let
lines = List.tail docs <&> \d -> end = docLit $ Text.pack ")"
docAddBaseY (BrIndentSpecial 2) lines =
$ docCols ColTyOpPrefix [docCommaSep, d] List.tail docs
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) <&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt docAlt
[ docSeq $ [docLit $ Text.pack "("] [ docSeq
++ docWrapNodeRest ltype commaDocs $ [docLit $ Text.pack "("]
++ [end] ++ docWrapNodeRest ltype commaDocs
++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in docPar in
(docAddBaseY (BrIndentSpecial 2) $ line1) docPar
(docLines $ docWrapNodeRest ltype lines ++ [end]) (docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end])
] ]
unboxedL = do unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let start = docParenHashLSep let
end = docParenHashRSep start = docParenHashLSep
end = docParenHashRSep
docAlt docAlt
[ docSeq $ [start] [ docSeq
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) $ [start]
++ [end] ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end]
, let , let
line1 = docCols ColTyOpPrefix [start, head docs] line1 = docCols ColTyOpPrefix [start, head docs]
lines = List.tail docs <&> \d -> lines =
docAddBaseY (BrIndentSpecial 2) List.tail docs
$ docCols ColTyOpPrefix [docCommaSep, d] <&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
in docPar in docPar
(docAddBaseY (BrIndentSpecial 2) line1) (docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ lines ++ [end]) (docLines $ lines ++ [end])
@ -419,20 +410,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docWrapNodeRest ltype [ docWrapNodeRest ltype $ docLit $ Text.pack
$ docLit ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
] ]
, docPar , docPar
( docLit (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) (docCols
) ColTyOpPrefix
(docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
[ docWrapNodeRest ltype , docAddBaseY (BrIndentSpecial 2) typeDoc1
$ docLit $ Text.pack ":: " ]
, docAddBaseY (BrIndentSpecial 2) typeDoc1 )
])
] ]
-- TODO: test KindSig -- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do HsKindSig _ typ1 kind1 -> do
@ -473,7 +462,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
else docPar else docPar
typeDoc1 typeDoc1
( docCols (docCols
ColTyOpPrefix ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: " [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1 , docAddBaseY (BrIndentSpecial 3) kindDoc1
@ -544,7 +533,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
let specialCommaSep = appSep $ docLit $ Text.pack " ," let specialCommaSep = appSep $ docLit $ Text.pack " ,"
docAlt docAlt
[ docSeq [ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
++ [docLit $ Text.pack "]"] ++ [docLit $ Text.pack "]"]
, case splitFirstLast typDocs of , case splitFirstLast typDocs of
@ -569,19 +558,23 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
FirstLast e1 ems eN -> runFilteredAlternative $ do FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) ++ List.intersperse
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
++ [docLit $ Text.pack " ]"] ++ [docLit $ Text.pack " ]"]
addAlternative $ addAlternative
let $ let
start = docCols ColList start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
[appSep $ docLit $ Text.pack "'[", e1] linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
linesM = ems <&> \d -> lineN = docCols
docCols ColList [specialCommaSep, d] ColList
lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
end = docLit $ Text.pack " ]" end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
] ]
HsExplicitTupleTy{} -> -- TODO HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
@ -592,8 +585,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ -> HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText" error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> HsWildCardTy _ -> docLit $ Text.pack "_"
docLit $ Text.pack "_"
HsSumTy{} -> -- TODO HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do HsStarTy _ isUnicode -> do
@ -606,14 +598,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
k <- docSharedWrapper layoutType kind k <- docSharedWrapper layoutType kind
docAlt docAlt
[ docSeq [ docSeq
[ docForceSingleline t [ docForceSingleline t
, docSeparator , docSeparator
, docLit $ Text.pack "@" , docLit $ Text.pack "@"
, docForceSingleline k , docForceSingleline k
] ]
, docPar , docPar t (docSeq [docLit $ Text.pack "@", k])
t
(docSeq [docLit $ Text.pack "@", k ])
] ]
layoutTyVarBndrs layoutTyVarBndrs

30
source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs
View File

@ -2,28 +2,24 @@
module Language.Haskell.Brittany.Internal.Obfuscation where module Language.Haskell.Brittany.Internal.Obfuscation where
import Data.Char
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Data.Char import Language.Haskell.Brittany.Internal.PreludeUtils
import System.Random import System.Random
obfuscate :: Text -> IO Text obfuscate :: Text -> IO Text
obfuscate input = do obfuscate input = do
let predi x = isAlphaNum x || x `elem` "_'" let predi x = isAlphaNum x || x `elem` "_'"
let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input)
let idents = Set.toList $ Set.fromList $ filter (all predi) groups let idents = Set.toList $ Set.fromList $ filter (all predi) groups
let exceptionFilter x | x `elem` keywords = False let
exceptionFilter x | x `elem` extraKWs = False exceptionFilter x | x `elem` keywords = False
exceptionFilter x = not $ null $ drop 1 x exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x = not $ null $ drop 1 x
let filtered = filter exceptionFilter idents let filtered = filter exceptionFilter idents
mappings <- fmap Map.fromList $ filtered `forM` \x -> do mappings <- fmap Map.fromList $ filtered `forM` \x -> do
r <- createAlias x r <- createAlias x
@ -75,14 +71,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"]
createAlias :: String -> IO String createAlias :: String -> IO String
createAlias xs = go NoHint xs createAlias xs = go NoHint xs
where where
go _hint "" = pure "" go _hint "" = pure ""
go hint (c : cr) = do go hint (c : cr) = do
c' <- case hint of c' <- case hint of
VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z']
_ | isUpper c -> randomFrom ['A' .. 'Z'] _ | isUpper c -> randomFrom ['A' .. 'Z']
VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z']
_ | isLower c -> randomFrom ['a' .. 'z'] _ | isLower c -> randomFrom ['a' .. 'z']
_ -> pure c _ -> pure c
cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr
pure (c' : cr') pure (c' : cr')

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

@ -1,346 +1,195 @@
module Language.Haskell.Brittany.Internal.Prelude ( module E ) where module Language.Haskell.Brittany.Internal.Prelude
( module E
) where
import GHC.Hs.Extension as E (GhcPs)
import GHC.Types.Name.Reader as E (RdrName)
import Control.Applicative as E (Alternative(..), Applicative(..))
-- rather project-specific stuff: import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second)
--------------------------------- import Control.Concurrent as E (forkIO, forkOS, threadDelay)
import GHC.Hs.Extension as E ( GhcPs ) import Control.Concurrent.Chan as E (Chan)
import Control.Concurrent.MVar as E
import GHC.Types.Name.Reader as E ( RdrName ) (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar)
import Control.Exception as E (assert, bracket, evaluate)
import Control.Monad as E
-- more general: ( (<$!>)
---------------- , (<=<)
, (=<<)
import Data.Functor.Identity as E ( Identity(..) ) , (>=>)
import Control.Concurrent.Chan as E ( Chan ) , Functor(..)
import Control.Concurrent.MVar as E ( MVar , Monad(..)
, newEmptyMVar , MonadPlus(..)
, newMVar , filterM
, putMVar , forM
, readMVar , forM_
, takeMVar , forever
, swapMVar , guard
) , join
import Data.Int as E ( Int ) , liftM
import Data.Word as E ( Word , liftM2
, Word32 , liftM3
) , liftM4
import Prelude as E ( Integer , liftM5
, Float , mapM
, Double , mapM_
, undefined , replicateM
, Eq (..) , replicateM_
, Ord (..) , sequence
, Enum (..) , sequence_
, Bounded (..) , unless
, (<$>) , void
, (.) , when
, ($) )
, ($!) import Control.Monad.Extra as E
, Num (..) (allM, andM, anyM, ifM, notM, orM, unlessM, whenM)
, Integral (..) import Control.Monad.IO.Class as E (MonadIO(..))
, Fractional (..) import Control.Monad.ST as E (ST)
, Floating (..) import Control.Monad.Trans.Class as E (lift)
, RealFrac (..) import Control.Monad.Trans.Maybe as E (MaybeT(..))
, RealFloat (..) import Control.Monad.Trans.MultiRWS as E
, fromIntegral (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet)
, error import Data.Bifunctor as E (bimap)
, foldr import Data.Bool as E (Bool(..))
, foldl import Data.Char as E (Char, chr, ord)
, foldr1 import Data.Data as E (toConstr)
, id import Data.Either as E (Either(..), either)
, map import Data.Foldable as E (asum, fold, foldl', foldr')
, subtract import Data.Function as E ((&), fix)
, putStrLn import Data.Functor as E (($>))
, putStr import Data.Functor.Identity as E (Identity(..))
, Show (..) import Data.IORef as E (IORef)
, print import Data.Int as E (Int)
, fst import Data.List as E
, snd ( all
, (++) , break
, not , drop
, (&&) , dropWhile
, (||) , elem
, curry , filter
, uncurry , find
, flip , intercalate
, const , intersperse
, seq , isPrefixOf
, reverse , isSuffixOf
, otherwise , iterate
, traverse , length
, realToFrac , mapAccumL
, or , mapAccumR
, and , maximum
, head , minimum
, any , notElem
, (^) , nub
, Foldable , null
, Traversable , partition
) , repeat
import Control.Monad.ST as E ( ST ) , replicate
import Data.Bool as E ( Bool(..) ) , sortBy
import Data.Char as E ( Char , sum
, ord , take
, chr , takeWhile
) , transpose
import Data.Either as E ( Either(..) , uncons
, either , unzip
) , zip
import Data.IORef as E ( IORef ) , zip3
import Data.Maybe as E ( Maybe(..) , zipWith
, fromMaybe )
, maybe import Data.List.Extra as E (nubOrd, stripSuffix)
, listToMaybe import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty)
, maybeToList import Data.Map as E (Map)
, catMaybes import Data.Maybe as E
) (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList)
import Data.Monoid as E ( Endo(..) import Data.Monoid as E
, All(..) ( All(..)
, Any(..) , Alt(..)
, Sum(..) , Any(..)
, Product(..) , Endo(..)
, Alt(..) , Monoid(..)
, mconcat , Product(..)
, Monoid (..) , Sum(..)
) , mconcat
import Data.Ord as E ( Ordering(..) )
, Down(..) import Data.Ord as E (Down(..), Ordering(..), comparing)
, comparing import Data.Proxy as E (Proxy(..))
) import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator)
import Data.Ratio as E ( Ratio import Data.Semigroup as E ((<>), Semigroup(..))
, Rational import Data.Sequence as E (Seq)
, (%) import Data.Set as E (Set)
, numerator import Data.String as E (String)
, denominator import Data.Text as E (Text)
) import Data.Tree as E (Tree(..))
import Data.String as E ( String ) import Data.Tuple as E (swap)
import Data.Void as E ( Void ) import Data.Typeable as E (Typeable)
import System.IO as E ( IO import Data.Version as E (showVersion)
, hFlush import Data.Void as E (Void)
, stdout import Data.Word as E (Word, Word32)
) import Debug.Trace as E
import Data.Proxy as E ( Proxy(..) ) ( trace
import Data.Sequence as E ( Seq ) , traceIO
, traceId
import Data.Map as E ( Map ) , traceM
import Data.Set as E ( Set ) , traceShow
, traceShowId
import Data.Text as E ( Text ) , traceShowM
, traceStack
import Data.Function as E ( fix )
, (&) import Foreign.ForeignPtr as E (ForeignPtr)
) import Foreign.Storable as E (Storable)
import GHC.Exts as E (Constraint)
import Data.Foldable as E ( foldl' import Prelude as E
, foldr' ( ($)
, fold , ($!)
, asum , (&&)
) , (++)
, (.)
import Data.List as E ( partition , (<$>)
, null , Bounded(..)
, elem , Double
, notElem , Enum(..)
, minimum , Eq(..)
, maximum , Float
, length , Floating(..)
, all , Foldable
, take , Fractional(..)
, drop , Integer
, find , Integral(..)
, sum , Num(..)
, zip , Ord(..)
, zip3 , RealFloat(..)
, zipWith , RealFrac(..)
, repeat , Show(..)
, replicate , Traversable
, iterate , (^)
, nub , and
, filter , any
, intersperse , const
, intercalate , curry
, isSuffixOf , error
, isPrefixOf , flip
, dropWhile , foldl
, takeWhile , foldr
, unzip , foldr1
, break , fromIntegral
, transpose , fst
, sortBy , head
, mapAccumL , id
, mapAccumR , map
, uncons , not
) , or
, otherwise
import Data.List.NonEmpty as E ( NonEmpty(..) , print
, nonEmpty , putStr
) , putStrLn
, realToFrac
import Data.Tuple as E ( swap , reverse
) , seq
, snd
import Text.Read as E ( readMaybe , subtract
) , traverse
, uncurry
import Control.Monad as E ( Functor (..) , undefined
, Monad (..) , (||)
, MonadPlus (..) )
, mapM import System.IO as E (IO, hFlush, stdout)
, mapM_ import Text.Read as E (readMaybe)
, forM
, forM_
, sequence
, sequence_
, (=<<)
, (>=>)
, (<=<)
, forever
, void
, join
, replicateM
, replicateM_
, guard
, when
, unless
, liftM
, liftM2
, liftM3
, liftM4
, liftM5
, filterM
, (<$!>)
)
import Control.Applicative as E ( Applicative (..)
, Alternative (..)
)
import Foreign.Storable as E ( Storable )
import GHC.Exts as E ( Constraint )
import Control.Concurrent as E ( threadDelay
, forkIO
, forkOS
)
import Control.Exception as E ( evaluate
, bracket
, assert
)
import Debug.Trace as E ( trace
, traceId
, traceShowId
, traceShow
, traceStack
, traceShowId
, traceIO
, traceM
, traceShowM
)
import Foreign.ForeignPtr as E ( ForeignPtr
)
import Data.Bifunctor as E ( bimap )
import Data.Functor as E ( ($>) )
import Data.Semigroup as E ( (<>)
, Semigroup(..)
)
import Data.Typeable as E ( Typeable
)
import Control.Arrow as E ( first
, second
, (***)
, (&&&)
, (>>>)
, (<<<)
)
import Data.Version as E ( showVersion
)
import Data.List.Extra as E ( nubOrd
, stripSuffix
)
import Control.Monad.Extra as E ( whenM
, unlessM
, ifM
, notM
, orM
, andM
, anyM
, allM
)
import Data.Tree as E ( Tree(..)
)
import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..)
-- , MultiRWSTNull
-- , MultiRWS
-- ,
MonadMultiReader(..)
, MonadMultiWriter(..)
, MonadMultiState(..)
, mGet
-- , runMultiRWST
-- , runMultiRWSTASW
-- , runMultiRWSTW
-- , runMultiRWSTAW
-- , runMultiRWSTSW
-- , runMultiRWSTNil
-- , runMultiRWSTNil_
-- , withMultiReader
-- , withMultiReader_
-- , withMultiReaders
-- , withMultiReaders_
-- , withMultiWriter
-- , withMultiWriterAW
-- , withMultiWriterWA
-- , withMultiWriterW
-- , withMultiWriters
-- , withMultiWritersAW
-- , withMultiWritersWA
-- , withMultiWritersW
-- , withMultiState
-- , withMultiStateAS
-- , withMultiStateSA
-- , withMultiStateA
-- , withMultiStateS
-- , withMultiState_
-- , withMultiStates
-- , withMultiStatesAS
-- , withMultiStatesSA
-- , withMultiStatesA
-- , withMultiStatesS
-- , withMultiStates_
-- , inflateReader
-- , inflateMultiReader
-- , inflateWriter
-- , inflateMultiWriter
-- , inflateState
-- , inflateMultiState
-- , mapMultiRWST
-- , mGetRawR
-- , mGetRawW
-- , mGetRawS
-- , mPutRawR
-- , mPutRawW
-- , mPutRawS
)
import Control.Monad.IO.Class as E ( MonadIO (..)
)
import Control.Monad.Trans.Class as E ( lift
)
import Control.Monad.Trans.Maybe as E ( MaybeT (..)
)
import Data.Data as E ( toConstr
)

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

@ -1,21 +1,15 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.Brittany.Internal.PreludeUtils where module Language.Haskell.Brittany.Internal.PreludeUtils where
import Control.Applicative
import Control.DeepSeq (NFData, force)
import Prelude import Control.Exception.Base (evaluate)
import Control.Monad
import qualified Data.Strict.Maybe as Strict import qualified Data.Strict.Maybe as Strict
import Debug.Trace import Debug.Trace
import Control.Monad import Prelude
import System.IO import System.IO
import Control.DeepSeq ( NFData, force )
import Control.Exception.Base ( evaluate )
import Control.Applicative
instance Applicative Strict.Maybe where instance Applicative Strict.Maybe where
pure = Strict.Just pure = Strict.Just
Strict.Just f <*> Strict.Just x = Strict.Just (f x) Strict.Just f <*> Strict.Just x = Strict.Just (f x)
@ -30,12 +24,12 @@ instance Alternative Strict.Maybe where
x <|> Strict.Nothing = x x <|> Strict.Nothing = x
_ <|> x = x _ <|> x = x
traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) traceFunctionWith
:: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
traceFunctionWith name s1 s2 f x = trace traceStr y traceFunctionWith name s1 s2 f x = trace traceStr y
where where
y = f x y = f x
traceStr = traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
(<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) :: Monad m => m a -> (a -> b) -> m b
(<&!>) = flip (<$!>) (<&!>) = flip (<$!>)
@ -51,10 +45,10 @@ printErr = putStrErrLn . show
errorIf :: Bool -> a -> a errorIf :: Bool -> a -> a
errorIf False = id errorIf False = id
errorIf True = error "errorIf" errorIf True = error "errorIf"
errorIfNote :: Maybe String -> a -> a errorIfNote :: Maybe String -> a -> a
errorIfNote Nothing = id errorIfNote Nothing = id
errorIfNote (Just x) = error x errorIfNote (Just x) = error x
(<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) :: Functor f => f a -> (a -> b) -> f b

1415
source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
View File

File diff suppressed because it is too large Load Diff

208
source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
View File

@ -3,16 +3,10 @@
module Language.Haskell.Brittany.Internal.Transformations.Columns where module Language.Haskell.Brittany.Internal.Transformations.Columns where
import Language.Haskell.Brittany.Internal.Prelude
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate 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
transformSimplifyColumns :: BriDoc -> BriDoc transformSimplifyColumns :: BriDoc -> BriDoc
transformSimplifyColumns = Uniplate.rewrite $ \case transformSimplifyColumns = Uniplate.rewrite $ \case
@ -20,118 +14,150 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
-- BDWrapAnnKey annKey $ transformSimplify bd -- BDWrapAnnKey annKey $ transformSimplify bd
BDEmpty -> Nothing BDEmpty -> Nothing
BDLit{} -> Nothing BDLit{} -> Nothing
BDSeq list | any (\case BDSeq{} -> True BDSeq list
BDEmpty{} -> True | any
_ -> False) list -> Just $ BDSeq $ list >>= \case (\case
BDEmpty -> [] BDSeq{} -> True
BDSeq l -> l BDEmpty{} -> True
x -> [x] _ -> False
BDSeq (BDCols sig1 cols1@(_:_):rest) )
| all (\case BDSeparator -> True; _ -> False) rest -> list
Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) -> Just $ BDSeq $ list >>= \case
BDLines lines | any (\case BDLines{} -> True BDEmpty -> []
BDEmpty{} -> True BDSeq l -> l
_ -> False) lines -> x -> [x]
Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDSeq (BDCols sig1 cols1@(_ : _) : rest)
| all
(\case
BDSeparator -> True
_ -> False
)
rest
-> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)])
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
-- prior floating in -- prior floating in
BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) -> BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l:lr) Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
-- post floating in -- post floating in
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) -> BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
-- ensureIndent float-in -- ensureIndent float-in
-- not sure if the following rule is necessary; tests currently are -- not sure if the following rule is necessary; tests currently are
-- unaffected. -- unaffected.
-- BDEnsureIndent indent (BDLines lines) -> -- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines -- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- matching col special transformation -- matching col special transformation
BDCols sig1 cols1@(_:_) BDCols sig1 cols1@(_ : _)
| BDLines lines@(_:_:_) <- List.last cols1 | BDLines lines@(_ : _ : _) <- List.last cols1
, BDCols sig2 cols2 <- List.last lines , BDCols sig2 cols2 <- List.last lines
, sig1==sig2 -> , sig1 == sig2
Just $ BDLines -> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDCols sig1 cols1@(_:_) BDCols sig1 cols1@(_ : _)
| BDLines lines@(_:_:_) <- List.last cols1 | BDLines lines@(_ : _ : _) <- List.last cols1
, BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines
, sig1==sig2 -> , sig1 == sig2
Just $ BDLines -> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 ->
Just $ BDAddBaseY ind (BDLines [col1, col2]) Just $ BDAddBaseY ind (BDLines [col1, col2])
BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest))
| sig1==sig2 -> | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
BDPar ind (BDLines lines1) col2@(BDCols sig2 _) BDPar ind (BDLines lines1) col2@(BDCols sig2 _)
| BDCols sig1 _ <- List.last lines1 | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
, sig1==sig2 -> $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest))
BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
| BDCols sig1 _ <- List.last lines1 $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
, sig1==sig2 ->
Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
-- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2))
-- | sig1==sig2 -> -- | sig1==sig2 ->
-- Just $ BDPar -- Just $ BDPar
-- ind1 -- ind1
-- (BDLines [BDCols sig1 cols1, BDCols sig]) -- (BDLines [BDCols sig1 cols1, BDCols sig])
BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols BDCols sig1 cols
, sig1==sig2 -> | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2
Just $ BDLines -> Just
[ BDCols sig1 (List.init cols ++ [line]) $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2]
BDCols sig1 cols
| BDPar ind line (BDLines lines) <- List.last cols
, BDCols sig2 cols2 <- List.last lines
, sig1 == sig2
-> Just $ BDLines
[ BDCols sig1
$ List.init cols
++ [BDPar ind line (BDLines $ List.init lines)]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols BDLines [x] -> Just $ x
, BDCols sig2 cols2 <- List.last lines BDLines [] -> Just $ BDEmpty
, sig1==sig2 -> BDSeq{} -> Nothing
Just $ BDLines BDCols{} -> Nothing
[ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] BDSeparator -> Nothing
, BDCols sig2 cols2 BDAddBaseY{} -> Nothing
] BDBaseYPushCur{} -> Nothing
BDLines [x] -> Just $ x BDBaseYPop{} -> Nothing
BDLines [] -> Just $ BDEmpty
BDSeq{} -> Nothing
BDCols{} -> Nothing
BDSeparator -> Nothing
BDAddBaseY{} -> Nothing
BDBaseYPushCur{} -> Nothing
BDBaseYPop{} -> Nothing
BDIndentLevelPushCur{} -> Nothing BDIndentLevelPushCur{} -> Nothing
BDIndentLevelPop{} -> Nothing BDIndentLevelPop{} -> Nothing
BDPar{} -> Nothing BDPar{} -> Nothing
BDAlt{} -> Nothing BDAlt{} -> Nothing
BDForceMultiline{} -> Nothing BDForceMultiline{} -> Nothing
BDForceSingleline{} -> Nothing BDForceSingleline{} -> Nothing
BDForwardLineMode{} -> Nothing BDForwardLineMode{} -> Nothing
BDExternal{} -> Nothing BDExternal{} -> Nothing
BDPlain{} -> Nothing BDPlain{} -> Nothing
BDLines{} -> Nothing BDLines{} -> Nothing
BDAnnotationPrior{} -> Nothing BDAnnotationPrior{} -> Nothing
BDAnnotationKW{} -> Nothing BDAnnotationKW{} -> Nothing
BDAnnotationRest{} -> Nothing BDAnnotationRest{} -> Nothing
BDMoveToKWDP{} -> Nothing BDMoveToKWDP{} -> Nothing
BDEnsureIndent{} -> Nothing BDEnsureIndent{} -> Nothing
BDSetParSpacing{} -> Nothing BDSetParSpacing{} -> Nothing
BDForceParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing
BDDebug{} -> Nothing BDDebug{} -> Nothing
BDNonBottomSpacing _ x -> Just x BDNonBottomSpacing _ x -> Just x

378
source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs
View File

@ -3,25 +3,20 @@
module Language.Haskell.Brittany.Internal.Transformations.Floating where module Language.Haskell.Brittany.Internal.Transformations.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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- note that this is not total, and cannot be with that exact signature. -- note that this is not total, and cannot be with that exact signature.
mergeIndents :: BrIndent -> BrIndent -> BrIndent mergeIndents :: BrIndent -> BrIndent -> BrIndent
mergeIndents BrIndentNone x = x mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) =
mergeIndents _ _ = error "mergeIndents" BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents"
transformSimplifyFloating :: BriDoc -> BriDoc transformSimplifyFloating :: BriDoc -> BriDoc
@ -31,169 +26,192 @@ transformSimplifyFloating = stepBO .> stepFull
-- better complexity. -- better complexity.
-- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence
-- the push/pop cases would need to be copied over -- the push/pop cases would need to be copied over
where where
descendPrior = transformDownMay $ \case descendPrior = transformDownMay $ \case
-- prior floating in -- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) -> BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) -> BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l:lr) Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
BDAnnotationPrior annKey1 (BDDebug s x) -> BDAnnotationPrior annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationPrior annKey1 x Just $ BDDebug s $ BDAnnotationPrior annKey1 x
_ -> Nothing _ -> Nothing
descendRest = transformDownMay $ \case descendRest = transformDownMay $ \case
-- post floating in -- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) -> BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
BDAnnotationRest annKey1 (BDLines list) -> $ BDSeq
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] $ List.init list
BDAnnotationRest annKey1 (BDCols sig cols) -> ++ [BDAnnotationRest annKey1 $ List.last list]
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] BDAnnotationRest annKey1 (BDLines list) ->
BDAnnotationRest annKey1 (BDAddBaseY indent x) -> Just
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x $ BDLines
BDAnnotationRest annKey1 (BDDebug s x) -> $ List.init list
Just $ BDDebug s $ BDAnnotationRest annKey1 x ++ [BDAnnotationRest annKey1 $ List.last list]
_ -> Nothing BDAnnotationRest annKey1 (BDCols sig cols) ->
descendKW = transformDownMay $ \case Just
-- post floating in $ BDCols sig
BDAnnotationKW annKey1 kw (BDPar ind line indented) -> $ List.init cols
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented ++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationRest annKey1 (BDDebug s x) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just $ BDDebug s $ BDAnnotationRest annKey1 x
BDAnnotationKW annKey1 kw (BDCols sig cols) -> _ -> Nothing
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] descendKW = transformDownMay $ \case
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> -- post floating in
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
BDAnnotationKW annKey1 kw (BDDebug s x) -> Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x BDAnnotationKW annKey1 kw (BDSeq list) ->
_ -> Nothing Just
descendBYPush = transformDownMay $ \case $ BDSeq
BDBaseYPushCur (BDCols sig cols@(_:_)) -> $ List.init list
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) ++ [BDAnnotationKW annKey1 kw $ List.last list]
BDBaseYPushCur (BDDebug s x) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDDebug s (BDBaseYPushCur x) Just
_ -> Nothing $ BDLines
descendBYPop = transformDownMay $ \case $ List.init list
BDBaseYPop (BDCols sig cols@(_:_)) -> ++ [BDAnnotationKW annKey1 kw $ List.last list]
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) BDAnnotationKW annKey1 kw (BDCols sig cols) ->
BDBaseYPop (BDDebug s x) -> Just
Just $ BDDebug s (BDBaseYPop x) $ BDCols sig
_ -> Nothing $ List.init cols
descendILPush = transformDownMay $ \case ++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDIndentLevelPushCur (BDDebug s x) -> BDAnnotationKW annKey1 kw (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPushCur x) Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
_ -> Nothing _ -> Nothing
descendILPop = transformDownMay $ \case descendBYPush = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols@(_:_)) -> BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDIndentLevelPop (BDDebug s x) -> BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x)
Just $ BDDebug s (BDIndentLevelPop x) _ -> Nothing
_ -> Nothing descendBYPop = transformDownMay $ \case
descendAddB = transformDownMay $ \case BDBaseYPop (BDCols sig cols@(_ : _)) ->
BDAddBaseY BrIndentNone x -> Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
Just x BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x)
-- AddIndent floats into Lines. _ -> Nothing
BDAddBaseY indent (BDLines lines) -> descendILPush = transformDownMay $ \case
Just $ BDLines $ BDAddBaseY indent <$> lines BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just
-- AddIndent floats into last column $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDAddBaseY indent (BDCols sig cols) -> BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] Just $ BDDebug s (BDIndentLevelPushCur x)
-- merge AddIndent and Par _ -> Nothing
BDAddBaseY ind1 (BDPar ind2 line indented) -> descendILPop = transformDownMay $ \case
Just $ BDPar (mergeIndents ind1 ind2) line indented BDIndentLevelPop (BDCols sig cols@(_ : _)) ->
BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x)
BDAddBaseY ind (BDAnnotationRest annKey1 x) -> _ -> Nothing
Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) descendAddB = transformDownMay $ \case
BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> BDAddBaseY BrIndentNone x -> Just x
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) -- AddIndent floats into Lines.
BDAddBaseY ind (BDSeq list) -> BDAddBaseY indent (BDLines lines) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDLines $ BDAddBaseY indent <$> lines
BDAddBaseY _ lit@BDLit{} -> -- AddIndent floats into last column
Just $ lit BDAddBaseY indent (BDCols sig cols) ->
BDAddBaseY ind (BDBaseYPushCur x) -> Just
Just $ BDBaseYPushCur (BDAddBaseY ind x) $ BDCols sig
BDAddBaseY ind (BDBaseYPop x) -> $ List.init cols
Just $ BDBaseYPop (BDAddBaseY ind x) ++ [BDAddBaseY indent $ List.last cols]
BDAddBaseY ind (BDDebug s x) -> -- merge AddIndent and Par
Just $ BDDebug s (BDAddBaseY ind x) BDAddBaseY ind1 (BDPar ind2 line indented) ->
BDAddBaseY ind (BDIndentLevelPop x) -> Just $ BDPar (mergeIndents ind1 ind2) line indented
Just $ BDIndentLevelPop (BDAddBaseY ind x) BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
BDAddBaseY ind (BDIndentLevelPushCur x) -> Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
Just $ BDIndentLevelPushCur (BDAddBaseY ind x) BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
BDAddBaseY ind (BDEnsureIndent ind2 x) -> Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
Just $ BDEnsureIndent (mergeIndents ind ind2) x BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
_ -> Nothing Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
stepBO :: BriDoc -> BriDoc BDAddBaseY ind (BDSeq list) ->
stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
transformUp f BDAddBaseY _ lit@BDLit{} -> Just $ lit
where BDAddBaseY ind (BDBaseYPushCur x) ->
f = \case Just $ BDBaseYPushCur (BDAddBaseY ind x)
x@BDAnnotationPrior{} -> descendPrior x BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
x@BDAnnotationKW{} -> descendKW x BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x)
x@BDAnnotationRest{} -> descendRest x BDAddBaseY ind (BDIndentLevelPop x) ->
x@BDAddBaseY{} -> descendAddB x Just $ BDIndentLevelPop (BDAddBaseY ind x)
x@BDBaseYPushCur{} -> descendBYPush x BDAddBaseY ind (BDIndentLevelPushCur x) ->
x@BDBaseYPop{} -> descendBYPop x Just $ BDIndentLevelPushCur (BDAddBaseY ind x)
x@BDIndentLevelPushCur{} -> descendILPush x BDAddBaseY ind (BDEnsureIndent ind2 x) ->
x@BDIndentLevelPop{} -> descendILPop x Just $ BDEnsureIndent (mergeIndents ind ind2) x
x -> x _ -> Nothing
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ stepBO :: BriDoc -> BriDoc
Uniplate.rewrite $ \case stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
BDAddBaseY BrIndentNone x -> transformUp f
Just $ x where
-- AddIndent floats into Lines. f = \case
BDAddBaseY indent (BDLines lines) -> x@BDAnnotationPrior{} -> descendPrior x
Just $ BDLines $ BDAddBaseY indent <$> lines x@BDAnnotationKW{} -> descendKW x
-- AddIndent floats into last column x@BDAnnotationRest{} -> descendRest x
BDAddBaseY indent (BDCols sig cols) -> x@BDAddBaseY{} -> descendAddB x
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] x@BDBaseYPushCur{} -> descendBYPush x
BDAddBaseY ind (BDSeq list) -> x@BDBaseYPop{} -> descendBYPop x
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] x@BDIndentLevelPushCur{} -> descendILPush x
-- merge AddIndent and Par x@BDIndentLevelPop{} -> descendILPop x
BDAddBaseY ind1 (BDPar ind2 line indented) -> x -> x
Just $ BDPar (mergeIndents ind1 ind2) line indented stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
BDAddBaseY _ lit@BDLit{} -> Uniplate.rewrite $ \case
Just $ lit BDAddBaseY BrIndentNone x -> Just $ x
BDAddBaseY ind (BDBaseYPushCur x) -> -- AddIndent floats into Lines.
Just $ BDBaseYPushCur (BDAddBaseY ind x) BDAddBaseY indent (BDLines lines) ->
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDLines $ BDAddBaseY indent <$> lines
Just $ BDBaseYPop (BDAddBaseY ind x) -- AddIndent floats into last column
-- prior floating in BDAddBaseY indent (BDCols sig cols) ->
BDAnnotationPrior annKey1 (BDPar ind line indented) -> Just
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented $ BDCols sig
BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> $ List.init cols
Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) ++ [BDAddBaseY indent $ List.last cols]
BDAnnotationPrior annKey1 (BDLines (l:lr)) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> -- merge AddIndent and Par
Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) BDAddBaseY ind1 (BDPar ind2 line indented) ->
-- EnsureIndent float-in Just $ BDPar (mergeIndents ind1 ind2) line indented
-- BDEnsureIndent indent (BDCols sig (col:colr)) -> BDAddBaseY _ lit@BDLit{} -> Just $ lit
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) BDAddBaseY ind (BDBaseYPushCur x) ->
-- not sure if the following rule is necessary; tests currently are Just $ BDBaseYPushCur (BDAddBaseY ind x)
-- unaffected. BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
-- BDEnsureIndent indent (BDLines lines) -> -- prior floating in
-- Just $ BDLines $ BDEnsureIndent indent <$> lines BDAnnotationPrior annKey1 (BDPar ind line indented) ->
-- post floating in Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationRest annKey1 (BDPar ind line indented) -> BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationRest annKey1 (BDCols sig cols) -> -- EnsureIndent float-in
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] -- BDEnsureIndent indent (BDCols sig (col:colr)) ->
_ -> Nothing -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
-- not sure if the following rule is necessary; tests currently are
-- 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]
_ -> Nothing

32
source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs
View File

@ -3,16 +3,10 @@
module Language.Haskell.Brittany.Internal.Transformations.Indent where module Language.Haskell.Brittany.Internal.Transformations.Indent where
import Language.Haskell.Brittany.Internal.Prelude
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate 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
-- prepare layouting by translating BDPar's, replacing them with Indents and -- prepare layouting by translating BDPar's, replacing them with Indents and
-- floating those in. This gives a more clear picture of what exactly is -- floating those in. This gives a more clear picture of what exactly is
@ -31,15 +25,17 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x -- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented -- , BDEnsureIndent ind indented
-- ] -- ]
BDLines lines | any ( \case BDLines lines
BDLines{} -> True | any
BDEmpty{} -> True (\case
_ -> False BDLines{} -> True
) BDEmpty{} -> True
lines -> _ -> False
Just $ BDLines $ filter isNotEmpty $ lines >>= \case )
lines
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
BDLines [l] -> Just l BDLines [l] -> Just l
BDAddBaseY i (BDAnnotationPrior k x) -> BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i x) Just $ BDAnnotationPrior k (BDAddBaseY i x)
@ -53,4 +49,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} -> Just lit BDAddBaseY _ lit@BDLit{} -> Just lit
_ -> Nothing _ -> Nothing

40
source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs
View File

@ -3,14 +3,9 @@
module Language.Haskell.Brittany.Internal.Transformations.Par where module Language.Haskell.Brittany.Internal.Transformations.Par where
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
transformSimplifyPar :: BriDoc -> BriDoc transformSimplifyPar :: BriDoc -> BriDoc
transformSimplifyPar = transformUp $ \case transformSimplifyPar = transformUp $ \case
@ -24,25 +19,28 @@ transformSimplifyPar = transformUp $ \case
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 (BDPar ind2 line p1) p2 ->
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines | any ( \case BDLines lines
BDLines{} -> True | any
BDEmpty{} -> True (\case
_ -> False BDLines{} -> True
) BDEmpty{} -> True
lines -> case go lines of _ -> False
[] -> BDEmpty )
[x] -> x lines
xs -> BDLines xs -> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
where where
go = (=<<) $ \case go = (=<<) $ \case
BDLines l -> go l BDLines l -> go l
BDEmpty -> [] BDEmpty -> []
x -> [x] x -> [x]
BDLines [] -> BDEmpty BDLines [] -> BDEmpty
BDLines [x] -> x BDLines [x] -> x
-- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- BDCols sig cols | BDPar ind line indented <- List.last cols ->
-- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented
-- BDPar BrIndentNone line indented -> -- BDPar BrIndentNone line indented ->
-- Just $ BDLines [line, indented] -- Just $ BDLines [line, indented]
BDEnsureIndent BrIndentNone x -> x BDEnsureIndent BrIndentNone x -> x
x -> x x -> x

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

@ -12,31 +12,20 @@
module Language.Haskell.Brittany.Internal.Types where module Language.Haskell.Brittany.Internal.Types where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.Data import qualified Data.Data
import qualified Data.Strict.Maybe as Strict import Data.Generics.Uniplate.Direct as Uniplate
import qualified Safe
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan )
import Language.Haskell.GHC.ExactPrint ( AnnKey )
import Language.Haskell.GHC.ExactPrint.Types ( Anns )
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
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
data PerItemConfig = PerItemConfig data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe) { _icd_perBinding :: Map String (CConfig Maybe)
@ -44,20 +33,26 @@ data PerItemConfig = PerItemConfig
} }
deriving Data.Data.Data deriving Data.Data.Data
type PPM = MultiRWSS.MultiRWS type PPM
'[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] = MultiRWSS.MultiRWS
'[Text.Builder.Builder, [BrittanyError], Seq String] '[ Map ExactPrint.AnnKey ExactPrint.Anns
'[] , PerItemConfig
, Config
, ExactPrint.Anns
]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[]
type PPMLocal = MultiRWSS.MultiRWS type PPMLocal
'[Config, ExactPrint.Anns] = MultiRWSS.MultiRWS
'[Text.Builder.Builder, [BrittanyError], Seq String] '[Config , ExactPrint.Anns]
'[] '[Text.Builder.Builder , [BrittanyError] , Seq String]
'[]
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
data LayoutState = LayoutState data LayoutState = LayoutState
{ _lstate_baseYs :: [Int] { _lstate_baseYs :: [Int]
-- ^ stack of number of current indentation columns -- ^ stack of number of current indentation columns
-- (not number of indentations). -- (not number of indentations).
, _lstate_curYOrAddNewline :: Either Int Int , _lstate_curYOrAddNewline :: Either Int Int
@ -65,7 +60,7 @@ data LayoutState = LayoutState
-- 1) number of chars in the current line. -- 1) number of chars in the current line.
-- 2) number of newlines to be inserted before inserting any -- 2) number of newlines to be inserted before inserting any
-- non-space elements. -- non-space elements.
, _lstate_indLevels :: [Int] , _lstate_indLevels :: [Int]
-- ^ stack of current indentation levels. set for -- ^ stack of current indentation levels. set for
-- any layout-affected elements such as -- any layout-affected elements such as
-- let/do/case/where elements. -- let/do/case/where elements.
@ -78,14 +73,14 @@ data LayoutState = LayoutState
-- on the first indented element have an -- on the first indented element have an
-- annotation offset relative to the last -- annotation offset relative to the last
-- non-indented element, which is confusing. -- non-indented element, which is confusing.
, _lstate_comments :: Anns , _lstate_comments :: Anns
, _lstate_commentCol :: Maybe Int -- this communicates two things: , _lstate_commentCol :: Maybe Int -- this communicates two things:
-- firstly, that cursor is currently -- firstly, that cursor is currently
-- at the end of a comment (so needs -- at the end of a comment (so needs
-- newline before any actual content). -- newline before any actual content).
-- secondly, the column at which -- secondly, the column at which
-- insertion of comments started. -- insertion of comments started.
, _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone
-- writes (any non-spaces) in the -- writes (any non-spaces) in the
-- current line. -- current line.
-- , _lstate_isNewline :: NewLineState -- , _lstate_isNewline :: NewLineState
@ -115,14 +110,21 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
instance Show LayoutState where instance Show LayoutState where
show state = show state =
"LayoutState" "LayoutState"
++ "{baseYs=" ++ show (_lstate_baseYs state) ++ "{baseYs="
++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) ++ show (_lstate_baseYs state)
++ ",indLevels=" ++ show (_lstate_indLevels state) ++ ",curYOrAddNewline="
++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ show (_lstate_curYOrAddNewline state)
++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",indLevels="
++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) ++ show (_lstate_indLevels state)
++ ",commentNewlines=" ++ show (_lstate_commentNewlines 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 -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a
-- -- newline, really. by special-casing -- -- newline, really. by special-casing
@ -223,14 +225,16 @@ data BrIndent = BrIndentNone
| BrIndentSpecial Int | BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show) deriving (Eq, Ord, Data.Data.Data, Show)
type ToBriDocM = MultiRWSS.MultiRWS type ToBriDocM
'[Config, Anns] -- reader = MultiRWSS.MultiRWS
'[[BrittanyError], Seq String] -- writer '[Config , Anns] -- reader
'[NodeAllocIndex] -- state '[[BrittanyError] , Seq String] -- writer
'[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc (sym :: Kind.Type -> Kind.Type)
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c
data DocMultiLine data DocMultiLine
= MultiLineNo = MultiLineNo
@ -338,21 +342,21 @@ type BriDocFInt = BriDocF ((,) Int)
type BriDocNumbered = (Int, BriDocFInt) type BriDocNumbered = (Int, BriDocFInt)
instance Uniplate.Uniplate BriDoc where instance Uniplate.Uniplate BriDoc where
uniplate x@BDEmpty{} = plate x uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x uniplate x@BDLit{} = plate x
uniplate (BDSeq list ) = plate BDSeq ||* list uniplate (BDSeq list) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts ) = plate BDAlt ||* alts uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x uniplate x@BDPlain{} = plate x
uniplate (BDAnnotationPrior annKey bd) = uniplate (BDAnnotationPrior annKey bd) =
plate BDAnnotationPrior |- annKey |* bd plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationKW annKey kw bd) = uniplate (BDAnnotationKW annKey kw bd) =
@ -361,83 +365,84 @@ instance Uniplate.Uniplate BriDoc where
plate BDAnnotationRest |- annKey |* bd plate BDAnnotationRest |- annKey |* bd
uniplate (BDMoveToKWDP annKey kw b bd) = uniplate (BDMoveToKWDP annKey kw b bd) =
plate BDMoveToKWDP |- annKey |- kw |- b |* bd plate BDMoveToKWDP |- annKey |- kw |- b |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines uniplate (BDLines lines) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd uniplate (BDDebug s bd) = plate BDDebug |- s |* bd
newtype NodeAllocIndex = NodeAllocIndex Int newtype NodeAllocIndex = NodeAllocIndex Int
-- TODO: rename to "dropLabels" ? -- TODO: rename to "dropLabels" ?
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
unwrapBriDocNumbered tpl = case snd tpl of unwrapBriDocNumbered tpl = case snd tpl of
BDFEmpty -> BDEmpty BDFEmpty -> BDEmpty
BDFLit t -> BDLit t BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented) BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t BDFExternal k ks c t -> BDExternal k ks c t
BDFPlain t -> BDPlain t BDFPlain t -> BDPlain t
BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd
BDFLines lines -> BDLines $ rec <$> lines BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where rec = unwrapBriDocNumbered where rec = unwrapBriDocNumbered
isNotEmpty :: BriDoc -> Bool isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False isNotEmpty BDEmpty = False
isNotEmpty _ = True isNotEmpty _ = True
-- this might not work. is not used anywhere either. -- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> () briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case briDocSeqSpine = \case
BDEmpty -> () BDEmpty -> ()
BDLit _t -> () BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeparator -> () BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented BDPar _ind line indented ->
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts briDocSeqSpine line `seq` briDocSeqSpine indented
BDForwardLineMode bd -> briDocSeqSpine bd BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDExternal{} -> () BDForwardLineMode bd -> briDocSeqSpine bd
BDPlain{} -> () BDExternal{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDPlain{} -> ()
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing _ bd -> briDocSeqSpine bd BDNonBottomSpacing _ bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd BDForceParSpacing bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd
briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine :: BriDoc -> BriDoc
briDocForceSpine bd = briDocSeqSpine bd `seq` bd briDocForceSpine bd = briDocSeqSpine bd `seq` bd
@ -456,18 +461,19 @@ data VerticalSpacingPar
-- product like (Normal|Always, None|Some Int). -- product like (Normal|Always, None|Some Int).
deriving (Eq, Show) deriving (Eq, Show)
data VerticalSpacing data VerticalSpacing = VerticalSpacing
= VerticalSpacing { _vs_sameLine :: !Int
{ _vs_sameLine :: !Int , _vs_paragraph :: !VerticalSpacingPar
, _vs_paragraph :: !VerticalSpacingPar , _vs_parFlag :: !Bool
, _vs_parFlag :: !Bool }
}
deriving (Eq, Show) deriving (Eq, Show)
newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
deriving (Functor, Applicative, Monad, Show, Alternative) deriving (Functor, Applicative, Monad, Show, Alternative)
pattern LineModeValid :: forall t. t -> LineModeValidity t pattern LineModeValid :: forall t . t -> LineModeValidity t
pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t pattern LineModeValid x =
pattern LineModeInvalid :: forall t. LineModeValidity t LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t pattern LineModeInvalid :: forall t . LineModeValidity t
pattern LineModeInvalid =
LineModeValidity Strict.Nothing :: LineModeValidity t

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

@ -7,40 +7,29 @@
module Language.Haskell.Brittany.Internal.Utils where module Language.Haskell.Brittany.Internal.Utils where
import qualified Data.ByteString as B
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Coerce 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.Semigroup as Semigroup
import qualified Data.Sequence as Seq 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 qualified GHC.OldList as List
import GHC.Types.Name.Occurrence as OccName (occNameString)
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 Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Data.Data
import Data.Generics.Aliases
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.Name.Occurrence as OccName ( occNameString )
import qualified Data.ByteString as B
import DataTreePrint
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.Hs.Extension as HsExtension
parDoc :: String -> PP.Doc parDoc :: String -> PP.Doc
parDoc = PP.fsep . fmap PP.text . List.words parDoc = PP.fsep . fmap PP.text . List.words
@ -55,7 +44,8 @@ showOutputable :: (GHC.Outputable a) => a -> String
showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y fromMaybeIdentity x y =
Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity :: Identity a -> Maybe a -> Identity a
fromOptionIdentity x y = fromOptionIdentity x y =
@ -70,24 +60,26 @@ instance (Num a, Ord a) => Semigroup (Max a) where
(<>) = Data.Coerce.coerce (max :: a -> a -> a) (<>) = Data.Coerce.coerce (max :: a -> a -> a)
instance (Num a, Ord a) => Monoid (Max a) where instance (Num a, Ord a) => Monoid (Max a) where
mempty = Max 0 mempty = Max 0
mappend = (<>) mappend = (<>)
newtype ShowIsId = ShowIsId String deriving Data newtype ShowIsId = ShowIsId String deriving Data
instance Show ShowIsId where show (ShowIsId x) = x instance Show ShowIsId where
show (ShowIsId x) = x
data A x = A ShowIsId x deriving Data data A x = A ShowIsId x
deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF = customLayouterF anns layoutF =
DataToLayouter DataToLayouter
$ f $ f
`extQ` showIsId `extQ` showIsId
`extQ` fastString `extQ` fastString
`extQ` bytestring `extQ` bytestring
`extQ` occName `extQ` occName
`extQ` srcSpan `extQ` srcSpan
`ext2Q` located `ext2Q` located
where where
DataToLayouter f = defaultLayouterF layoutF DataToLayouter f = defaultLayouterF layoutF
@ -95,18 +87,22 @@ customLayouterF anns layoutF =
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s Left True -> PP.parens $ PP.text s
Left False -> PP.text s Left False -> PP.text s
Right _ -> PP.text s Right _ -> PP.text s
fastString = fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter srcSpan ss =
simpleLayouter
-- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{" ++ showOutputable ss ++ "}" $ "{"
++ showOutputable ss
++ "}"
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where where
@ -118,12 +114,12 @@ customLayouterF anns layoutF =
customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF = customLayouterNoAnnsF layoutF =
DataToLayouter DataToLayouter
$ f $ f
`extQ` showIsId `extQ` showIsId
`extQ` fastString `extQ` fastString
`extQ` bytestring `extQ` bytestring
`extQ` occName `extQ` occName
`extQ` srcSpan `extQ` srcSpan
`ext2Q` located `ext2Q` located
where where
DataToLayouter f = defaultLayouterF layoutF DataToLayouter f = defaultLayouterF layoutF
@ -131,14 +127,15 @@ customLayouterNoAnnsF layoutF =
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s Left True -> PP.parens $ PP.text s
Left False -> PP.text s Left False -> PP.text s
Right _ -> PP.text s Right _ -> PP.text s
fastString = fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
@ -202,12 +199,11 @@ traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
tellDebugMess :: MonadMultiWriter tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
(Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow :: forall a m . (MonadMultiWriter tellDebugMessShow
(Seq String) m, Show a) => a -> m () :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show tellDebugMessShow = tellDebugMess . show
-- i should really put that into multistate.. -- i should really put that into multistate..
@ -222,29 +218,28 @@ briDocToDoc = astToDoc . removeAnnotations
where where
removeAnnotations = Uniplate.transform $ \case removeAnnotations = Uniplate.transform $ \case
BDAnnotationPrior _ x -> x BDAnnotationPrior _ x -> x
BDAnnotationKW _ _ x -> x BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x BDAnnotationRest _ x -> x
x -> x x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) annsDoc =
printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], []) breakEither _ [] = ([], [])
breakEither fn (a1:aR) = case fn a1 of breakEither fn (a1 : aR) = case fn a1 of
Left b -> (b : bs, cs) Left b -> (b : bs, cs)
Right c -> (bs, c : cs) Right c -> (bs, c : cs)
where where (bs, cs) = breakEither fn aR
(bs, cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs)
where where (ys, xs) = spanMaybe f xR
(ys, xs) = spanMaybe f xR spanMaybe _ xs = ([], xs)
spanMaybe _ xs = ([], xs)
data FirstLastView a data FirstLastView a
= FirstLastEmpty = FirstLastEmpty
@ -254,7 +249,7 @@ data FirstLastView a
splitFirstLast :: [a] -> FirstLastView a splitFirstLast :: [a] -> FirstLastView a
splitFirstLast [] = FirstLastEmpty splitFirstLast [] = FirstLastEmpty
splitFirstLast [x] = FirstLastSingleton x splitFirstLast [x] = FirstLastSingleton x
splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr)
-- TODO: move to uniplate upstream? -- TODO: move to uniplate upstream?
-- aka `transform` -- aka `transform`
@ -273,7 +268,7 @@ lines' :: String -> [String]
lines' s = case break (== '\n') s of lines' s = case break (== '\n') s of
(s1, []) -> [s1] (s1, []) -> [s1]
(s1, [_]) -> [s1, ""] (s1, [_]) -> [s1, ""]
(s1, (_:r)) -> s1 : lines' r (s1, (_ : r)) -> s1 : lines' r
absurdExt :: HsExtension.NoExtCon -> a absurdExt :: HsExtension.NoExtCon -> a
absurdExt = HsExtension.noExtCon absurdExt = HsExtension.noExtCon

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

@ -4,58 +4,41 @@
module Language.Haskell.Brittany.Main where module Language.Haskell.Brittany.Main where
import Control.Monad (zipWithM)
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.Except as ExceptT
import Data.CZipWith
import qualified Data.Either import qualified Data.Either
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Monoid
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import DataTreePrint
import GHC (GenLocated(L))
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List import qualified GHC.OldList as List
import qualified System.IO import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)
import Language.Haskell.Brittany.Internal
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } import Language.Haskell.Brittany.Internal.Config
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.Brittany.Internal.Config.Types
import qualified Data.Monoid import Language.Haskell.Brittany.Internal.Obfuscation
import Language.Haskell.Brittany.Internal.Prelude
import GHC ( GenLocated(L) ) import Language.Haskell.Brittany.Internal.PreludeUtils
import GHC.Utils.Outputable ( Outputable(..) import Language.Haskell.Brittany.Internal.Types
, showSDocUnsafe import Language.Haskell.Brittany.Internal.Utils
) import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Paths_brittany
import Text.Read ( Read(..) ) import qualified System.Directory as Directory
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import Control.Monad ( zipWithM )
import Data.CZipWith
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Obfuscation
import qualified Text.PrettyPrint as PP
import DataTreePrint
import UI.Butcher.Monadic
import qualified System.Exit import qualified System.Exit
import qualified System.Directory as Directory import qualified System.FilePath.Posix as FilePath
import qualified System.FilePath.Posix as FilePath import qualified System.IO
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified GHC.Driver.Session as GHC import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified GHC.LanguageExtensions.Type as GHC import qualified Text.PrettyPrint as PP
import Text.Read (Read(..))
import Paths_brittany import UI.Butcher.Monadic
data WriteMode = Display | Inplace data WriteMode = Display | Inplace
@ -110,7 +93,7 @@ helpDoc = PP.vcat $ List.intersperse
] ]
, parDoc $ "See https://github.com/lspitzner/brittany" , parDoc $ "See https://github.com/lspitzner/brittany"
, parDoc , parDoc
$ "Please report bugs at" $ "Please report bugs at"
++ " https://github.com/lspitzner/brittany/issues" ++ " https://github.com/lspitzner/brittany/issues"
] ]
@ -147,15 +130,16 @@ mainCmdParser helpDesc = do
addCmd "license" $ addCmdImpl $ print $ licenseDoc addCmd "license" $ addCmdImpl $ print $ licenseDoc
-- addButcherDebugCommand -- addButcherDebugCommand
reorderStart reorderStart
printHelp <- addSimpleBoolFlag "h" ["help"] mempty printHelp <- addSimpleBoolFlag "h" ["help"] mempty
printVersion <- addSimpleBoolFlag "" ["version"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty
noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty
configPaths <- addFlagStringParams "" configPaths <- addFlagStringParams
["config-file"] ""
"PATH" ["config-file"]
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? "PATH"
cmdlineConfig <- cmdlineConfigParser (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- cmdlineConfigParser
suppressOutput <- addSimpleBoolFlag suppressOutput <- addSimpleBoolFlag
"" ""
["suppress-output"] ["suppress-output"]
@ -181,7 +165,7 @@ mainCmdParser helpDesc = do
"" ""
["write-mode"] ["write-mode"]
"(display|inplace)" "(display|inplace)"
( flagHelp (flagHelp
(PP.vcat (PP.vcat
[ PP.text "display: output for any input(s) goes to stdout" [ PP.text "display: output for any input(s) goes to stdout"
, PP.text "inplace: override respective input file (without backup!)" , PP.text "inplace: override respective input file (without backup!)"
@ -211,11 +195,13 @@ mainCmdParser helpDesc = do
$ ppHelpShallow helpDesc $ ppHelpShallow helpDesc
System.Exit.exitSuccess System.Exit.exitSuccess
let inputPaths = let
if null inputParams then [Nothing] else map Just inputParams inputPaths =
let outputPaths = case writeMode of if null inputParams then [Nothing] else map Just inputParams
Display -> repeat Nothing let
Inplace -> inputPaths outputPaths = case writeMode of
Display -> repeat Nothing
Inplace -> inputPaths
configsToLoad <- liftIO $ if null configPaths configsToLoad <- liftIO $ if null configPaths
then then
@ -230,14 +216,15 @@ mainCmdParser helpDesc = do
) )
>>= \case >>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
Just x -> return x Just x -> return x
when (config & _conf_debug & _dconf_dump_config & confUnpack) when (config & _conf_debug & _dconf_dump_config & confUnpack)
$ trace (showConfigYaml config) $ trace (showConfigYaml config)
$ return () $ return ()
results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) results <- zipWithM
inputPaths (coreIO putStrErrLn config suppressOutput checkMode)
outputPaths inputPaths
outputPaths
if checkMode if checkMode
then when (Changes `elem` (Data.Either.rights results)) then when (Changes `elem` (Data.Either.rights results))
@ -266,58 +253,65 @@ coreIO
-> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status.
coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
ExceptT.runExceptT $ do ExceptT.runExceptT $ do
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let
putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-- there is a good of code duplication between the following code and the -- there is a good of code duplication between the following code and the
-- `pureModuleTransform` function. Unfortunately, there are also a good -- `pureModuleTransform` function. Unfortunately, there are also a good
-- amount of slight differences: This module is a bit more verbose, and -- amount of slight differences: This module is a bit more verbose, and
-- it tries to use the full-blown `parseModule` function which supports -- it tries to use the full-blown `parseModule` function which supports
-- CPP (but requires the input to be a file..). -- CPP (but requires the input to be a file..).
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
-- the flag will do the following: insert a marker string -- the flag will do the following: insert a marker string
-- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
-- "#include" before processing (parsing) input; and remove that marker -- "#include" before processing (parsing) input; and remove that marker
-- string from the transformation output. -- string from the transformation output.
-- The flag is intentionally misspelled to prevent clashing with -- The flag is intentionally misspelled to prevent clashing with
-- inline-config stuff. -- inline-config stuff.
let hackAroundIncludes = let
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack hackAroundIncludes =
let exactprintOnly = viaGlobal || viaDebug config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
where let
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack exactprintOnly = viaGlobal || viaDebug
viaDebug = where
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags let
then case cppMode of cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
CPPModeAbort -> do then case cppMode of
return $ Left "Encountered -XCPP. Aborting." CPPModeAbort -> do
CPPModeWarn -> do return $ Left "Encountered -XCPP. Aborting."
putErrorLnIO CPPModeWarn -> do
$ "Warning: Encountered -XCPP." putErrorLnIO
++ " Be warned that -XCPP is not supported and that" $ "Warning: Encountered -XCPP."
++ " brittany cannot check that its output is syntactically" ++ " Be warned that -XCPP is not supported and that"
++ " valid in its presence." ++ " brittany cannot check that its output is syntactically"
return $ Right True ++ " valid in its presence."
CPPModeNowarn -> return $ Right True return $ Right True
else return $ Right False CPPModeNowarn -> return $ Right True
else return $ Right False
(parseResult, originalContents) <- case inputPathM of (parseResult, originalContents) <- case inputPathM of
Nothing -> do Nothing -> do
-- TODO: refactor this hack to not be mixed into parsing logic -- TODO: refactor this hack to not be mixed into parsing logic
let hackF s = if "#include" `isPrefixOf` s let
then "-- BRITANY_INCLUDE_HACK " ++ s hackF s = if "#include" `isPrefixOf` s
else s then "-- BRITANY_INCLUDE_HACK " ++ s
let hackTransform = if hackAroundIncludes && not exactprintOnly else s
then List.intercalate "\n" . fmap hackF . lines' let
else id hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines'
else id
inputString <- liftIO System.IO.getContents inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString ghcOptions parseRes <- liftIO $ parseModuleFromString
"stdin" ghcOptions
cppCheckFunc "stdin"
(hackTransform inputString) cppCheckFunc
(hackTransform inputString)
return (parseRes, Text.pack inputString) return (parseRes, Text.pack inputString)
Just p -> liftIO $ do Just p -> liftIO $ do
parseRes <- parseModule ghcOptions p cppCheckFunc parseRes <- parseModule ghcOptions p cppCheckFunc
inputText <- Text.IO.readFile p inputText <- Text.IO.readFile p
-- The above means we read the file twice, but the -- The above means we read the file twice, but the
-- GHC API does not really expose the source it -- GHC API does not really expose the source it
@ -346,10 +340,12 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
pure c pure c
let moduleConf = cZipWith fromOptionIdentity config inlineConf let moduleConf = cZipWith fromOptionIdentity config inlineConf
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource let
val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return () trace ("---- ast ----\n" ++ show val) $ return ()
let disableFormatting = let
moduleConf & _conf_disable_formatting & confUnpack disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack
(errsWarns, outSText, hasChanges) <- do (errsWarns, outSText, hasChanges) <- do
if if
| disableFormatting -> do | disableFormatting -> do
@ -358,46 +354,52 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let r = Text.pack $ ExactPrint.exactPrint parsedSource anns let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
pure ([], r, r /= originalContents) pure ([], r, r /= originalContents)
| otherwise -> do | otherwise -> do
let omitCheck = let
moduleConf omitCheck =
& _conf_errorHandling moduleConf
.> _econf_omit_output_valid_check & _conf_errorHandling
.> confUnpack .> _econf_omit_output_valid_check
.> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return then return
$ pPrintModule moduleConf perItemConf anns parsedSource $ pPrintModule moduleConf perItemConf anns parsedSource
else liftIO $ pPrintModuleAndCheck moduleConf else liftIO $ pPrintModuleAndCheck
perItemConf moduleConf
anns perItemConf
parsedSource anns
let hackF s = fromMaybe s $ TextL.stripPrefix parsedSource
(TextL.pack "-- BRITANY_INCLUDE_HACK ") let
s hackF s = fromMaybe s $ TextL.stripPrefix
let out = TextL.toStrict $ if hackAroundIncludes (TextL.pack "-- BRITANY_INCLUDE_HACK ")
then s
TextL.intercalate (TextL.pack "\n") let
$ hackF out = TextL.toStrict $ if hackAroundIncludes
<$> TextL.splitOn (TextL.pack "\n") outRaw then
else outRaw TextL.intercalate (TextL.pack "\n")
$ hackF
<$> TextL.splitOn (TextL.pack "\n") outRaw
else outRaw
out' <- if moduleConf & _conf_obfuscate & confUnpack out' <- if moduleConf & _conf_obfuscate & confUnpack
then lift $ obfuscate out then lift $ obfuscate out
else pure out else pure out
pure $ (ews, out', out' /= originalContents) pure $ (ews, out', out' /= originalContents)
let customErrOrder ErrorInput{} = 4 let
customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorInput{} = 4
customErrOrder ErrorOutputCheck{} = 1 customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do unless (null errsWarns) $ do
let groupedErrsWarns = let
Data.List.Extra.groupOn customErrOrder groupedErrsWarns =
$ List.sortOn customErrOrder Data.List.Extra.groupOn customErrOrder
$ errsWarns $ List.sortOn customErrOrder
$ errsWarns
groupedErrsWarns `forM_` \case groupedErrsWarns `forM_` \case
(ErrorOutputCheck{} : _) -> do (ErrorOutputCheck{} : _) -> do
putErrorLn putErrorLn
$ "ERROR: brittany pretty printer" $ "ERROR: brittany pretty printer"
++ " returned syntactically invalid result." ++ " returned syntactically invalid result."
(ErrorInput str : _) -> do (ErrorInput str : _) -> do
putErrorLn $ "ERROR: parse error: " ++ str putErrorLn $ "ERROR: parse error: " ++ str
@ -406,9 +408,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ "WARNING: encountered unknown syntactical constructs:" $ "WARNING: encountered unknown syntactical constructs:"
uns `forM_` \case uns `forM_` \case
ErrorUnknownNode str ast@(L loc _) -> do ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) putErrorLn $ " " <> str <> " at " <> showSDocUnsafe
(ppr loc)
when when
( config (config
& _conf_debug & _conf_debug
& _dconf_dump_ast_unknown & _dconf_dump_ast_unknown
& confUnpack & confUnpack
@ -422,17 +425,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
putErrorLn $ "WARNINGS:" putErrorLn $ "WARNINGS:"
warns `forM_` \case warns `forM_` \case
LayoutWarning str -> putErrorLn str LayoutWarning str -> putErrorLn str
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
unused@(ErrorUnusedComment{} : _) -> do unused@(ErrorUnusedComment{} : _) -> do
putErrorLn putErrorLn
$ "Error: detected unprocessed comments." $ "Error: detected unprocessed comments."
++ " The transformation output will most likely" ++ " The transformation output will most likely"
++ " not contain some of the comments" ++ " not contain some of the comments"
++ " present in the input haskell source file." ++ " present in the input haskell source file."
putErrorLn $ "Affected are the following comments:" putErrorLn $ "Affected are the following comments:"
unused `forM_` \case unused `forM_` \case
ErrorUnusedComment str -> putErrorLn str ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
(ErrorMacroConfig err input : _) -> do (ErrorMacroConfig err input : _) -> do
putErrorLn $ "Error: parse error in inline configuration:" putErrorLn $ "Error: parse error in inline configuration:"
putErrorLn err putErrorLn err
@ -443,8 +446,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let let
hasErrors = hasErrors =
if config & _conf_errorHandling & _econf_Werror & confUnpack if config & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns) else 0 < maximum (-1 : fmap customErrOrder errsWarns)
outputOnErrs = outputOnErrs =
config config
& _conf_errorHandling & _conf_errorHandling
@ -459,10 +462,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ addTraceSep (_conf_debug config) $ addTraceSep (_conf_debug config)
$ case outputPathM of $ case outputPathM of
Nothing -> liftIO $ Text.IO.putStr $ outSText Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do Just p -> liftIO $ do
let isIdentical = case inputPathM of let
Nothing -> False isIdentical = case inputPathM of
Just _ -> not hasChanges Nothing -> False
Just _ -> not hasChanges
unless isIdentical $ Text.IO.writeFile p $ outSText unless isIdentical $ Text.IO.writeFile p $ outSText
when (checkMode && hasChanges) $ case inputPathM of when (checkMode && hasChanges) $ case inputPathM of
@ -474,15 +478,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
where where
addTraceSep conf = addTraceSep conf =
if or if or
[ confUnpack $ _dconf_dump_annotations conf [ confUnpack $ _dconf_dump_annotations conf
, confUnpack $ _dconf_dump_ast_unknown conf , confUnpack $ _dconf_dump_ast_unknown conf
, confUnpack $ _dconf_dump_ast_full conf , confUnpack $ _dconf_dump_ast_full conf
, confUnpack $ _dconf_dump_bridoc_raw conf , confUnpack $ _dconf_dump_bridoc_raw conf
, confUnpack $ _dconf_dump_bridoc_simpl_alt conf , confUnpack $ _dconf_dump_bridoc_simpl_alt conf
, confUnpack $ _dconf_dump_bridoc_simpl_floating conf , confUnpack $ _dconf_dump_bridoc_simpl_floating conf
, confUnpack $ _dconf_dump_bridoc_simpl_columns conf , confUnpack $ _dconf_dump_bridoc_simpl_columns conf
, confUnpack $ _dconf_dump_bridoc_simpl_indent conf , confUnpack $ _dconf_dump_bridoc_simpl_indent conf
, confUnpack $ _dconf_dump_bridoc_final conf , confUnpack $ _dconf_dump_bridoc_final conf
] ]
then trace "----" then trace "----"
else id else id

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

@ -2,35 +2,24 @@
{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
import Language.Haskell.Brittany.Internal.Prelude import Data.Coerce (coerce)
import Data.List (groupBy)
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified GHC.OldList as List import qualified GHC.OldList as List
import qualified System.Directory import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Test.Hspec import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Text.Parsec as Parsec
import Text.Parsec.Text ( Parser )
import Data.List ( groupBy )
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config
import Data.Coerce ( coerce )
import qualified Data.Text.IO as Text.IO
import System.FilePath ( (</>) )
import System.Timeout ( timeout )
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified System.Directory
import System.FilePath ((</>))
import System.Timeout (timeout)
import Test.Hspec
import qualified Text.Parsec as Parsec
import Text.Parsec.Text (Parser)
hush :: Either a b -> Maybe b hush :: Either a b -> Maybe b
hush = either (const Nothing) Just hush = either (const Nothing) Just
@ -40,32 +29,32 @@ hush = either (const Nothing) Just
asymptoticPerfTest :: Spec asymptoticPerfTest :: Spec
asymptoticPerfTest = do asymptoticPerfTest = do
it "10 do statements" it "10 do statements"
$ roundTripEqualWithTimeout 1500000 $ roundTripEqualWithTimeout 1500000
$ (Text.pack "func = do\n") $ (Text.pack "func = do\n")
<> Text.replicate 10 (Text.pack " statement\n") <> Text.replicate 10 (Text.pack " statement\n")
it "10 do nestings" it "10 do nestings"
$ roundTripEqualWithTimeout 4000000 $ roundTripEqualWithTimeout 4000000
$ (Text.pack "func = ") $ (Text.pack "func = ")
<> mconcat <> mconcat
( [1 .. 10] ([1 .. 10] <&> \(i :: Int) ->
<&> \(i :: Int) -> (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
) )
<> Text.replicate 2000 (Text.pack " ") <> Text.replicate 2000 (Text.pack " ")
<> Text.pack "return\n" <> Text.pack "return\n"
<> Text.replicate 2002 (Text.pack " ") <> Text.replicate 2002 (Text.pack " ")
<> Text.pack "()" <> Text.pack "()"
it "10 AppOps" it "10 AppOps"
$ roundTripEqualWithTimeout 1000000 $ roundTripEqualWithTimeout 1000000
$ (Text.pack "func = expr") $ (Text.pack "func = expr")
<> Text.replicate 10 (Text.pack "\n . expr") --TODO <> Text.replicate 10 (Text.pack "\n . expr") --TODO
roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout :: Int -> Text -> Expectation
roundTripEqualWithTimeout time t = roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
where where
action = fmap (fmap PPTextWrapper) action = fmap
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) (fmap PPTextWrapper)
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
data InputLine data InputLine
@ -85,10 +74,11 @@ data TestCase = TestCase
main :: IO () main :: IO ()
main = do main = do
files <- System.Directory.listDirectory "data/" files <- System.Directory.listDirectory "data/"
let blts = let
List.sort blts =
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) List.sort
$ filter (".blt" `isSuffixOf`) files $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
$ filter (".blt" `isSuffixOf`) files
inputs <- blts `forM` \blt -> Text.IO.readFile ("data" </> blt) inputs <- blts `forM` \blt -> Text.IO.readFile ("data" </> blt)
let groups = createChunks =<< inputs let groups = createChunks =<< inputs
inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt" inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt"
@ -99,15 +89,17 @@ main = do
it "gives properly formatted result for valid input" $ do it "gives properly formatted result for valid input" $ do
let let
input = Text.pack $ unlines input = Text.pack $ unlines
["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] [ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"
let expected = Text.pack $ unlines ]
[ "func =" let
, " [ 00000000000000000000000" expected = Text.pack $ unlines
, " , 00000000000000000000000" [ "func ="
, " , 00000000000000000000000" , " [ 00000000000000000000000"
, " , 00000000000000000000000" , " , 00000000000000000000000"
, " ]" , " , 00000000000000000000000"
] , " , 00000000000000000000000"
, " ]"
]
output <- liftIO $ parsePrintModule staticDefaultConfig input output <- liftIO $ parsePrintModule staticDefaultConfig input
hush output `shouldBe` Just expected hush output `shouldBe` Just expected
groups `forM_` \(groupname, tests) -> do groups `forM_` \(groupname, tests) -> do
@ -154,30 +146,33 @@ main = do
testProcessor = \case testProcessor = \case
HeaderLine n : rest -> HeaderLine n : rest ->
let normalLines = Data.Maybe.mapMaybe extractNormal rest let normalLines = Data.Maybe.mapMaybe extractNormal rest
in TestCase in
{ testName = n TestCase
, isPending = any isPendingLine rest { testName = n
, content = Text.unlines normalLines , isPending = any isPendingLine rest
} , content = Text.unlines normalLines
}
l -> l ->
error $ "first non-empty line must start with #test footest\n" ++ show l error
$ "first non-empty line must start with #test footest\n"
++ show l
extractNormal (NormalLine l) = Just l extractNormal (NormalLine l) = Just l
extractNormal _ = Nothing extractNormal _ = Nothing
isPendingLine PendingLine{} = True isPendingLine PendingLine{} = True
isPendingLine _ = False isPendingLine _ = False
specialLineParser :: Parser InputLine specialLineParser :: Parser InputLine
specialLineParser = Parsec.choice specialLineParser = Parsec.choice
[ [ GroupLine $ Text.pack name [ [ GroupLine $ Text.pack name
| _ <- Parsec.try $ Parsec.string "#group" | _ <- Parsec.try $ Parsec.string "#group"
, _ <- Parsec.many1 $ Parsec.oneOf " \t" , _ <- Parsec.many1 $ Parsec.oneOf " \t"
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
, _ <- Parsec.eof , _ <- Parsec.eof
] ]
, [ HeaderLine $ Text.pack name , [ HeaderLine $ Text.pack name
| _ <- Parsec.try $ Parsec.string "#test" | _ <- Parsec.try $ Parsec.string "#test"
, _ <- Parsec.many1 $ Parsec.oneOf " \t" , _ <- Parsec.many1 $ Parsec.oneOf " \t"
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
, _ <- Parsec.eof , _ <- Parsec.eof
] ]
, [ PendingLine , [ PendingLine
| _ <- Parsec.try $ Parsec.string "#pending" | _ <- Parsec.try $ Parsec.string "#pending"
@ -197,17 +192,17 @@ main = do
] ]
lineMapper :: Text -> InputLine lineMapper :: Text -> InputLine
lineMapper line = case Parsec.runParser specialLineParser () "" line of lineMapper line = case Parsec.runParser specialLineParser () "" line of
Left _e -> NormalLine line Left _e -> NormalLine line
Right l -> l Right l -> l
lineIsSpace :: InputLine -> Bool lineIsSpace :: InputLine -> Bool
lineIsSpace CommentLine = True lineIsSpace CommentLine = True
lineIsSpace _ = False lineIsSpace _ = False
grouperG :: InputLine -> InputLine -> Bool grouperG :: InputLine -> InputLine -> Bool
grouperG _ GroupLine{} = False grouperG _ GroupLine{} = False
grouperG _ _ = True grouperG _ _ = True
grouperT :: InputLine -> InputLine -> Bool grouperT :: InputLine -> InputLine -> Bool
grouperT _ HeaderLine{} = False grouperT _ HeaderLine{} = False
grouperT _ _ = True grouperT _ _ = True
-------------------- --------------------
@ -225,43 +220,42 @@ instance Show PPTextWrapper where
show (PPTextWrapper t) = "\n" ++ Text.unpack t show (PPTextWrapper t) = "\n" ++ Text.unpack t
-- brittany-next-binding --columns 160 -- brittany-next-binding --columns 160
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
defaultTestConfig :: Config defaultTestConfig :: Config
defaultTestConfig = Config defaultTestConfig = Config
{ _conf_version = _conf_version staticDefaultConfig { _conf_version = _conf_version staticDefaultConfig
, _conf_debug = _conf_debug staticDefaultConfig , _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int) { _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True , _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True , _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int) , _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_importAsColumn = coerce (60 :: Int) , _lconfig_importAsColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False , _lconfig_hangingTypeSignature = coerce False
, _lconfig_reformatModulePreamble = coerce True , _lconfig_reformatModulePreamble = coerce True
, _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowSingleLineExportList = coerce True
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False -- , _lconfig_allowSinglelineRecord = coerce False
} }
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True }
, _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_preprocessor = _conf_preprocessor staticDefaultConfig
, _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_forward = ForwardOptions { _options_ghc = Identity [] }
, _conf_roundtrip_exactprint_only = coerce False , _conf_roundtrip_exactprint_only = coerce False
, _conf_disable_formatting = coerce False , _conf_disable_formatting = coerce False
, _conf_obfuscate = coerce False , _conf_obfuscate = coerce False
} }
contextFreeTestConfig :: Config contextFreeTestConfig :: Config
contextFreeTestConfig = defaultTestConfig contextFreeTestConfig = defaultTestConfig
{ _conf_layout = (_conf_layout defaultTestConfig) { _conf_layout = (_conf_layout defaultTestConfig)
{ _lconfig_indentPolicy = coerce IndentPolicyLeft { _lconfig_indentPolicy = coerce IndentPolicyLeft
, _lconfig_alignmentLimit = coerce (1 :: Int) , _lconfig_alignmentLimit = coerce (1 :: Int)
, _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled
} }
} }