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

Revert "Format Brittany with Brittany" 

This reverts commit 4398b5880d.
pull/357/head
Taylor Fausak 2021-11-07 12:37:49 +00:00 committed by GitHub
parent 4398b5880d
commit 4079981b1d
33 changed files with 4804 additions and 4693 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
brittany.yaml
View File

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

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

@ -16,9 +16,13 @@ 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.Types import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config

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

@ -12,52 +12,68 @@ 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 Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Yaml
import qualified GHC hiding (parseModule)
import GHC (GenLocated(L))
import GHC.Data.Bag
import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.SrcLoc (SrcSpan) -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import Language.Haskell.Brittany.Internal.Backend import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.Brittany.Internal.BackendUtils import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Indent
import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified UI.Butcher.Monadic as Butcher import Control.Monad.Trans.Except
import Data.HList.HList
import qualified Data.Yaml
import Data.CZipWith
import qualified UI.Butcher.Monadic as Butcher
import qualified Data.Text.Lazy.Builder as Text.Builder
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Backend
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC
hiding ( parseModule )
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import GHC ( GenLocated(L)
)
import GHC.Types.SrcLoc ( SrcSpan )
import GHC.Hs
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
@ -75,36 +91,35 @@ 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 let configLiness = commentLiness <&> second
configLiness = commentLiness <&> second (Data.Maybe.mapMaybe $ \line -> do
(Data.Maybe.mapMaybe $ \line -> do l1 <-
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
<|> List.stripPrefix "--brittany" line <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") let l2 = dropWhile isSpace l1
let l2 = dropWhile isSpace l1 guard
guard ( ("@" `isPrefixOf` l2)
(("@" `isPrefixOf` l2) || ("-disable" `isPrefixOf` l2)
|| ("-disable" `isPrefixOf` l2) || ("-next" `isPrefixOf` l2)
|| ("-next" `isPrefixOf` l2) || ("{" `isPrefixOf` l2)
|| ("{" `isPrefixOf` l2) || ("--" `isPrefixOf` l2)
|| ("--" `isPrefixOf` l2) )
) pure l2
pure l2 )
)
let let
configParser = Butcher.addAlternatives configParser = Butcher.addAlternatives
[ ( "commandline-config" [ ( "commandline-config"
@ -123,44 +138,39 @@ 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 let nextDecl = do
nextDecl = do conf <- configParser
conf <- configParser Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
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 let nextBinding = do
nextBinding = do conf <- configParser
conf <- configParser Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
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 let disableNextBinding = do
disableNextBinding = do Butcher.addCmdImpl
Butcher.addCmdImpl ( InlineConfigTargetNextBinding
( InlineConfigTargetNextBinding , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
, 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 let disableNextDecl = do
disableNextDecl = do Butcher.addCmdImpl
Butcher.addCmdImpl ( InlineConfigTargetNextDecl
( InlineConfigTargetNextDecl , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
, 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 let disableFormatting = do
disableFormatting = do Butcher.addCmdImpl
Butcher.addCmdImpl ( InlineConfigTargetModule
( InlineConfigTargetModule , mempty { _conf_disable_formatting = pure $ pure True }
, 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
@ -168,42 +178,41 @@ 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 let perModule = foldl'
perModule = foldl' (<>)
(<>) mempty
mempty [ conf
[ conf | (_ , lineConfigs) <- lineConfigss
| (_, lineConfigs) <- lineConfigss , (InlineConfigTargetModule, conf ) <- lineConfigs
, (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 InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
| Just name <- Map.lookup k declNameMap -> [name] [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 ->
@ -221,7 +230,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]
] ]
@ -239,78 +248,70 @@ 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 let config =
config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let config_pp = config & _conf_preprocessor
let config_pp = config & _conf_preprocessor let cppMode = config_pp & _ppconf_CPPMode & confUnpack
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 let hackF s = if "#include" `isPrefixOf` s
hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s
then "-- BRITANY_INCLUDE_HACK " ++ s else s
else s let hackTransform = if hackAroundIncludes
let then List.intercalate "\n" . fmap hackF . lines'
hackTransform = if hackAroundIncludes else id
then List.intercalate "\n" . fmap hackF . lines' let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
else id then case cppMode of
let CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags CPPModeWarn -> return $ Right True
then case cppMode of CPPModeNowarn -> return $ Right True
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." else return $ Right False
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 let omitCheck =
omitCheck = moduleConfig
moduleConfig & _conf_errorHandling
& _conf_errorHandling & _econf_omit_output_valid_check
& _econf_omit_output_valid_check & confUnpack
& 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 let hackF s = fromMaybe s
hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
then then
( ews ( ews
, TextL.intercalate (TextL.pack "\n") , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn
$ hackF (TextL.pack "\n")
<$> TextL.splitOn (TextL.pack "\n") outRaw outRaw
) )
else (ews, outRaw) else (ews, outRaw)
let let customErrOrder ErrorInput{} = 4
customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder LayoutWarning{} = 0 :: Int customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorMacroConfig{} = 5
customErrOrder ErrorMacroConfig{} = 5 let hasErrors =
let if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
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
@ -330,27 +331,26 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([BrittanyError], TextL.Text) -> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule = pPrintModule conf inlineConf anns parsedModule =
let let ((out, errs), debugStrings) =
((out, errs), debugStrings) = runIdentity
runIdentity $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiReader conf
$ MultiRWSS.withMultiReader conf $ MultiRWSS.withMultiReader inlineConf
$ MultiRWSS.withMultiReader inlineConf $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ do
$ do traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns
$ annsDoc anns ppModule parsedModule
ppModule parsedModule tracer = if Seq.null debugStrings
tracer = if Seq.null debugStrings then id
then id else
else trace ("---- DEBUGMESSAGES ---- ")
trace ("---- DEBUGMESSAGES ---- ") . foldr (seq . join trace) id debugStrings
. foldr (seq . join trace) id debugStrings in tracer $ (errs, Text.Builder.toLazyText out)
in tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do -- unless () $ do
-- --
-- debugStrings `forM_` \s -> -- debugStrings `forM_` \s ->
@ -365,17 +365,15 @@ 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 parseResult <- parseModuleFromString ghcOptions
ghcOptions "output"
"output" (\_ -> return $ Right ())
(\_ -> return $ Right ()) (TextL.unpack output)
(TextL.unpack output) let errs' = errs ++ case parseResult of
let Left{} -> [ErrorOutputCheck]
errs' = errs ++ case parseResult of Right{} -> []
Left{} -> [ErrorOutputCheck]
Right{} -> []
return (errs', output) return (errs', output)
@ -386,22 +384,18 @@ 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 -> Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
Right (anns, parsedModule) -> runExceptT $ do Right (anns, parsedModule) -> runExceptT $ do
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
case case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) Left err -> throwE $ "error in inline config: " ++ show err
of Right x -> pure x
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 let omitCheck =
omitCheck = conf
conf & _conf_errorHandling
& _conf_errorHandling .> _econf_omit_output_valid_check
.> _econf_omit_output_valid_check .> confUnpack
.> 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
@ -411,13 +405,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
@ -470,30 +464,27 @@ 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 let mBindingConfs =
mBindingConfs = declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf filteredAnns <- mAsk
filteredAnns <- mAsk <&> \annMap -> <&> \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 traceIfDumpConf "bridoc annotations filtered/transformed"
"bridoc annotations filtered/transformed" _dconf_dump_annotations
_dconf_dump_annotations
$ annsDoc filteredAnns $ annsDoc filteredAnns
config <- mAsk config <- mAsk
let let config' = cZipWith fromOptionIdentity config
config' = cZipWith fromOptionIdentity config $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
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
@ -506,34 +497,33 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd layoutBriDoc bd
let let finalComments = filter
finalComments = filter (fst .> \case
(fst .> \case ExactPrint.AnnComment{} -> True
ExactPrint.AnnComment{} -> True _ -> False
_ -> 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 let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of ExactPrint.AnnComment cm
ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier 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
@ -550,9 +540,8 @@ 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 let shouldReformatPreamble =
shouldReformatPreamble = config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let let
(filteredAnns', post) = (filteredAnns', post) =
@ -562,23 +551,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 (filteredAnns'', post') in
traceIfDumpConf (filteredAnns'', post')
"bridoc annotations filtered/transformed" traceIfDumpConf "bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns' $ annsDoc filteredAnns'
if shouldReformatPreamble if shouldReformatPreamble
@ -587,7 +576,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
@ -600,7 +589,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"
@ -618,67 +607,63 @@ 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 .> traceIfDumpConf "bridoc post-floating"
"bridoc post-floating" _dconf_dump_bridoc_simpl_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 let state = LayoutState { _lstate_baseYs = [0]
state = LayoutState , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
{ _lstate_baseYs = [0] -- here because moveToAnn stuff
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left -- of the first node needs to do
-- here because moveToAnn stuff -- its thing properly.
-- of the first node needs to do , _lstate_indLevels = [0]
-- its thing properly. , _lstate_indLevelLinger = 0
, _lstate_indLevels = [0] , _lstate_comments = anns
, _lstate_indLevelLinger = 0 , _lstate_commentCol = Nothing
, _lstate_comments = anns , _lstate_addSepSpace = Nothing
, _lstate_commentCol = Nothing , _lstate_commentNewlines = 0
, _lstate_addSepSpace = Nothing }
, _lstate_commentNewlines = 0
}
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let let remainingComments =
remainingComments = [ c
[ c | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList (_lstate_comments state')
(_lstate_comments state') -- With the new import layouter, we manually process comments
-- With the new import layouter, we manually process comments -- without relying on the backend to consume the comments out of
-- without relying on the backend to consume the comments out of -- the state/map. So they will end up here, and we need to ignore
-- the state/map. So they will end up here, and we need to ignore -- them.
-- them. , ExactPrint.unConName con /= "ImportDecl"
, ExactPrint.unConName con /= "ImportDecl" , c <- extractAllComments elemAnns
, 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,6 +6,10 @@
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
@ -17,32 +21,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
type ColIndex = Int import Language.Haskell.Brittany.Internal.LayouterBasics
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 type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
= IntMapL.IntMap {- ColIndex -} type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
(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
@ -52,23 +56,20 @@ data ColInfo
instance Show ColInfo where instance Show ColInfo where
show ColInfoStart = "ColInfoStart" show ColInfoStart = "ColInfoStart"
show (ColInfoNo bd) = show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
"ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
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 type LayoutConstraints m = ( MonadMultiReader Config m
= ( MonadMultiReader Config m , MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiReader ExactPrint.Types.Anns m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter (Seq String) m
, MonadMultiWriter (Seq String) m , MonadMultiState LayoutState m
, MonadMultiState LayoutState m )
)
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case layoutBriDocM = \case
@ -89,11 +90,10 @@ layoutBriDocM = \case
BDSeparator -> do BDSeparator -> do
layoutAddSepSpace layoutAddSepSpace
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
let let indentF = case indent of
indentF = case indent of BrIndentNone -> id
BrIndentNone -> id BrIndentRegular -> layoutWithAddBaseCol
BrIndentRegular -> layoutWithAddBaseCol BrIndentSpecial i -> layoutWithAddBaseColN i
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
layoutBaseYPushCur layoutBaseYPushCur
@ -108,39 +108,36 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
layoutIndentLevelPop layoutIndentLevelPop
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
let let indentF = case indent of
indentF = case indent of BrIndentNone -> id
BrIndentNone -> id BrIndentRegular -> layoutWithAddBaseCol
BrIndentRegular -> layoutWithAddBaseCol BrIndentSpecial i -> layoutWithAddBaseColN i
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 let indentF = case indent of
indentF = case indent of BrIndentNone -> id
BrIndentNone -> id BrIndentRegular -> layoutWithAddBaseCol
BrIndentRegular -> layoutWithAddBaseCol BrIndentSpecial i -> layoutWithAddBaseColN i
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 let tlines = Text.lines $ t <> Text.pack "\n"
tlines = Text.lines $ t <> Text.pack "\n" tlineCount = length tlines
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
@ -157,10 +154,9 @@ 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 let moveToExactLocationAction = case _lstate_curYOrAddNewline state of
moveToExactLocationAction = case _lstate_curYOrAddNewline state of Left{} -> pure ()
Left{} -> pure () Right{} -> moveToExactAnn annKey
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
@ -171,8 +167,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
@ -180,10 +176,9 @@ 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
@ -195,20 +190,18 @@ 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 let mToSpan = case mAnn of
mToSpan = case mAnn of Just anns | Maybe.isNothing keyword -> Just anns
Just anns | Maybe.isNothing keyword -> Just anns Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just
Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> annR
Just annR _ -> Nothing
_ -> Nothing
case mToSpan of case mToSpan of
Just anns -> do Just anns -> do
let let (comments, rest) = flip spanMaybe anns $ \case
(comments, rest) = flip spanMaybe anns $ \case (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) _ -> Nothing
_ -> Nothing
mSet $ state mSet $ state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annsDP = rest }) (\ann -> ann { ExactPrint.annsDP = rest })
@ -220,19 +213,17 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> pure () Nothing -> pure ()
Just comments -> do Just comments -> do
comments comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (comment /= "(" && comment /= ")") $ do
when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment
let commentLines = Text.lines $ Text.pack $ comment -- evil hack for CPP:
-- evil hack for CPP: case comment of
case comment of ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)
('#' : _) -> _ -> layoutMoveToCommentPos y x (length commentLines)
layoutMoveToCommentPos y (-999) (length commentLines) -- 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 }
BDAnnotationRest annKey bd -> do BDAnnotationRest annKey bd -> do
layoutBriDocM bd layoutBriDocM bd
@ -241,26 +232,21 @@ 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 let semiCount = length [ ()
semiCount = length | Just ann <- [ annMay ]
[ () , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
| Just ann <- [annMay] ]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann shouldAddSemicolonNewlines <- mAsk <&>
] _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 ( \ann -> ann { ExactPrint.annFollowingComments = []
{ ExactPrint.annFollowingComments = [] , ExactPrint.annPriorComments = []
, ExactPrint.annPriorComments = [] , ExactPrint.annsDP =
, ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False (ExactPrint.Types.AnnComment{}, _) -> False
_ -> True _ -> True
} }
) )
annKey annKey
(_lstate_comments state) (_lstate_comments state)
@ -268,40 +254,37 @@ 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 comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> 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) 1
('#' : _) -> layoutMoveToCommentPos y (-999) 1 -- ^ evil hack for CPP
-- ^ evil hack for CPP ")" -> pure ()
")" -> pure () -- ^ fixes the formatting of parens
-- ^ fixes the formatting of parens -- on the lhs of type alias defs
-- on the lhs of type alias defs _ -> 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 layoutWriteAppendMultiline commentLines
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 let relevant = [ dp
relevant = | Just ann <- [mAnn]
[ dp , (ExactPrint.Types.G kw1, dp) <- ann
| Just ann <- [mAnn] , keyword == kw1
, (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
@ -312,8 +295,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
@ -324,73 +307,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
-- ========= -- =========
@ -475,16 +458,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) =
@ -501,41 +484,40 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
where alignMax' = max 0 alignMax where alignMax' = max 0 alignMax
processedMap :: ColMap2 processedMap :: ColMap2
processedMap = fix $ \result -> processedMap =
_cbs_map finalState <&> \(lastFlag, colSpacingss) -> fix $ \result -> _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 reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
$ (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 (ratio, maxCols, colss) in
(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)
@ -563,27 +545,28 @@ 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 && briDocIsMultiLine bd && case bd of shouldBreakAfter bd = alignBreak &&
(BDCols ColTyOpPrefix _) -> False briDocIsMultiLine bd && case bd of
(BDCols ColPatternsFuncPrefix _) -> True (BDCols ColTyOpPrefix _) -> False
(BDCols ColPatternsFuncInfix _) -> True (BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatterns _) -> True (BDCols ColPatternsFuncInfix _) -> True
(BDCols ColCasePattern _) -> True (BDCols ColPatterns _) -> True
(BDCols ColBindingLine{} _) -> True (BDCols ColCasePattern _) -> True
(BDCols ColGuard _) -> True (BDCols ColBindingLine{} _) -> True
(BDCols ColGuardedBody _) -> True (BDCols ColGuard _) -> True
(BDCols ColBindStmt _) -> True (BDCols ColGuardedBody _) -> True
(BDCols ColDoLet _) -> True (BDCols ColBindStmt _) -> True
(BDCols ColRec _) -> False (BDCols ColDoLet _) -> True
(BDCols ColRecUpdate _) -> False (BDCols ColRec _) -> False
(BDCols ColRecDecl _) -> False (BDCols ColRecUpdate _) -> False
(BDCols ColListComp _) -> False (BDCols ColRecDecl _) -> False
(BDCols ColList _) -> False (BDCols ColListComp _) -> False
(BDCols ColApp{} _) -> True (BDCols ColList _) -> False
(BDCols ColTuple _) -> False (BDCols ColApp{} _) -> True
(BDCols ColTuples _) -> False (BDCols ColTuple _) -> False
(BDCols ColOpPrefix _) -> False (BDCols ColTuples _) -> False
_ -> True (BDCols ColOpPrefix _) -> False
_ -> True
mergeInfoBriDoc mergeInfoBriDoc
:: Bool :: Bool
@ -591,22 +574,23 @@ 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 -> do | infoSig == colSig && length subLengthsInfos == length subDocs
-> 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
@ -615,17 +599,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 -> briDocToColInfo lastFlag brdc | otherwise
-> 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 let isLastList =
isLastList = if lastFlag then (==length list) <$> [1 ..] else repeat False
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
@ -633,11 +617,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
@ -652,14 +636,13 @@ 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 <- alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack curX <- do
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
@ -671,11 +654,10 @@ 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 let maxCols2 = list <&> \case
maxCols2 = list <&> \case (_, ColInfo i _ _) ->
(_, ColInfo i _ _) -> let Just (_, ms, _) = IntMapS.lookup i m in sum ms
let Just (_, ms, _) = IntMapS.lookup i m in sum ms (l, _) -> l
(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
@ -686,48 +668,46 @@ 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 let fixedPosXs = case alignMode of
fixedPosXs = case alignMode of ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) where
where factor :: Float =
factor :: Float = -- 0.0001 as an offering to the floating point gods.
-- 0.0001 as an offering to the floating point gods. min
min 1.0001
1.0001 (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) offsets = (subtract curX) <$> posXs
offsets = (subtract curX) <$> posXs fixed = offsets <&> fromIntegral .> (*factor) .> truncate
fixed = offsets <&> fromIntegral .> (* factor) .> truncate _ -> posXs
_ -> posXs let spacings = zipWith (-)
let (List.tail fixedPosXs ++ [min maxX colMax])
spacings = fixedPosXs
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 let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do layoutWriteEnsureAbsoluteN destX
layoutWriteEnsureAbsoluteN destX processInfo s m (snd x)
processInfo s m (snd x) noAlignAct = list `forM_` (snd .> processInfoIgnore)
noAlignAct = list `forM_` (snd .> processInfoIgnore) animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ if List.last fixedPosXs + fst (List.last list) > colMax
if List.last fixedPosXs + fst (List.last list) > colMax -- per-item check if there is overflowing.
-- per-item check if there is overflowing. then noAlignAct
then noAlignAct else alignAct
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)

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

@ -3,29 +3,42 @@
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 Data.Text.Lazy.Builder as Text.Builder
import GHC (Located)
import qualified GHC.OldList as List 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
traceLocal :: (MonadMultiState LayoutState m) => a -> m () 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 Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Internal.Utils
import GHC ( Located )
traceLocal
:: (MonadMultiState LayoutState m)
=> a
-> m ()
traceLocal _ = return () traceLocal _ = return ()
layoutWriteAppend layoutWriteAppend
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Text => Text
-> m () -> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
@ -41,13 +54,15 @@ 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteAppendSpaces i = do layoutWriteAppendSpaces i = do
@ -55,18 +70,20 @@ 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder 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
@ -74,15 +91,16 @@ 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewlineBlock = do layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock") traceLocal ("layoutWriteNewlineBlock")
state <- mGet state <- mGet
mSet $ state mSet $ state { _lstate_curYOrAddNewline = Right 1
{ _lstate_curYOrAddNewline = Right 1 , _lstate_addSepSpace = Just $ lstate_baseY state
, _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 ()
@ -98,13 +116,13 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state -- else _lstate_indLevelLinger state + i - _lstate_curY state
-- } -- }
layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol
:: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol = do layoutSetCommentCol = do
state <- mGet state <- mGet
let let col = case _lstate_curYOrAddNewline state of
col = 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
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 }
@ -112,7 +130,9 @@ 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> Int -> Int
-> Int -> Int
@ -122,35 +142,38 @@ 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 = Just $ case _lstate_commentCol state of , _lstate_commentCol =
Just existing -> existing Just $ case _lstate_commentCol state of
Nothing -> case _lstate_curYOrAddNewline state of Just existing -> existing
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Nothing -> case _lstate_curYOrAddNewline state of
Right{} -> lstate_baseY state Left i -> i + fromMaybe 0 (_lstate_addSepSpace 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder 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 ()
@ -158,67 +181,77 @@ _layoutResetCommentNewlines = do
mModify $ \state -> state { _lstate_commentNewlines = 0 } mModify $ \state -> state { _lstate_commentNewlines = 0 }
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
state <- mGet state <- mGet
let let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of (Just c , _ ) -> n - c
(Just c, _) -> n - c (Nothing, Left i ) -> n - i
(Nothing, Left i) -> n - i (Nothing, Right{}) -> n
(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 :: (MonadMultiState LayoutState m) => Int -> m () layoutBaseYPushInternal
:: (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 :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal
:: (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) => Int -> m () :: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutIndentLevelPushInternal i = do layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i) traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
{ _lstate_indLevelLinger = lstate_indLevel s , _lstate_indLevels = i : _lstate_indLevels s
, _lstate_indLevels = i : _lstate_indLevels s }
}
layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal = do layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal") traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
{ _lstate_indLevelLinger = lstate_indLevel s , _lstate_indLevels = List.tail $ _lstate_indLevels 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
@ -250,7 +283,9 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWithAddBaseColNBlock layoutWithAddBaseColNBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -263,23 +298,27 @@ layoutWithAddBaseColNBlock amount m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWriteEnsureBlock layoutWriteEnsureBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -289,36 +328,39 @@ layoutWithAddBaseColN amount m = do
m m
layoutBaseYPopInternal layoutBaseYPopInternal
layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur
:: (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 :: (MonadMultiState LayoutState m) => m () layoutBaseYPop
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do layoutBaseYPop = do
traceLocal ("layoutBaseYPop") traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal layoutBaseYPopInternal
layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur = do layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur") traceLocal ("layoutIndentLevelPushCur")
state <- mGet state <- mGet
let let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of (Left i , Just j ) -> i + j
(Left i, Just j) -> i + j (Left i , Nothing) -> i
(Left i, Nothing) -> i (Right{}, Just j ) -> j
(Right{}, Just j) -> j (Right{}, Nothing) -> 0
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y layoutIndentLevelPushInternal y
layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop = do layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop") traceLocal ("layoutIndentLevelPop")
layoutIndentLevelPopInternal layoutIndentLevelPopInternal
@ -328,12 +370,12 @@ layoutIndentLevelPop = do
-- make sense. -- make sense.
layoutRemoveIndentLevelLinger layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () layoutAddSepSpace :: (MonadMultiState LayoutState 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.
@ -348,7 +390,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
@ -357,19 +399,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 let upd = case _lstate_curYOrAddNewline state of
upd = 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 i -> Right $ max y i
Right i -> Right $ max y i in state
in { _lstate_curYOrAddNewline = upd
state , _lstate_addSepSpace = if Data.Either.isRight upd
{ _lstate_curYOrAddNewline = upd then
, _lstate_addSepSpace = if Data.Either.isRight upd _lstate_commentCol state
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just <|> _lstate_addSepSpace state
(lstate_baseY state) <|> Just (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
@ -379,7 +421,9 @@ moveToY y = mModify $ \state ->
-- else x -- else x
ppmMoveToExactLoc ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () :: MonadMultiWriter Text.Builder.Builder 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 " "
@ -395,77 +439,75 @@ 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 = Map.adjust { _lstate_comments =
(\ann -> ann { ExactPrint.annPriorComments = [] }) Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns
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 priors `forM_` \( ExactPrint.Comment comment _ _
`forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do , ExactPrint.DP (x, y)
replicateM_ x layoutWriteNewline ) -> do
layoutWriteAppendSpaces y replicateM_ x layoutWriteNewline
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment layoutWriteAppendSpaces y
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 layoutWritePostComments :: (Data.Data.Data ast,
:: ( Data.Data.Data ast MonadMultiWriter Text.Builder.Builder m,
, MonadMultiWriter Text.Builder.Builder m MonadMultiState LayoutState m)
, MonadMultiState LayoutState m => Located ast -> 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 = Map.adjust { _lstate_comments =
(\ann -> ann { ExactPrint.annFollowingComments = [] }) Map.adjust (\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 _ _, ExactPrint.DP (x, y)) -> posts `forM_` \( ExactPrint.Comment comment _ _
do , ExactPrint.DP (x, y)
replicateM_ x layoutWriteNewline ) -> do
layoutWriteAppend $ Text.pack $ replicate y ' ' replicateM_ x layoutWriteNewline
mModify $ \s -> s { _lstate_addSepSpace = Nothing } layoutWriteAppend $ Text.pack $ replicate y ' '
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment layoutIndentRestorePostComment
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) :: ( MonadMultiState LayoutState 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 mModify $ \s -> s { _lstate_commentCol = Nothing
$ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } , _lstate_commentNewlines = 0
}
case (mCommentCol, eCurYAddNL) of case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do (Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)
0 _ -> return ()
(_lstate_addSepSpace state)
_ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m, -- MonadMultiWriter Text.Builder.Builder m,

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

@ -3,174 +3,185 @@
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 Data.Yaml
import qualified GHC.OldList as List 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
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified System.IO import qualified System.IO
import UI.Butcher.Monadic
import qualified Data.Yaml
import Data.CZipWith
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 --columns 200 -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 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)
@ -217,8 +228,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)
@ -232,12 +243,11 @@ 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 globalConfig <- Directory.findFileWith Directory.doesFileExist
Directory.doesFileExist searchDirs
searchDirs "config.yaml"
"config.yaml"
maybe (writeUserConfig userBritPathXdg) pure globalConfig maybe (writeUserConfig userBritPathXdg) pure globalConfig
where where
writeUserConfig dir = do writeUserConfig dir = do
@ -249,7 +259,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"
@ -261,9 +271,8 @@ readConfigs
-> MaybeT IO Config -> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths configs <- readConfig `mapM` configPaths
let let merged = Semigroup.sconcat
merged = $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
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,54 +7,63 @@
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
@ -139,17 +148,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.
@ -159,21 +168,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
@ -184,9 +193,10 @@ 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,16 +18,22 @@
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
@ -102,18 +108,17 @@ 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) = parseJSON (Object v) = Config
Config <$> v .:? Key.fromString "conf_version"
<$> (v .:? Key.fromString "conf_version") <*> v .:?= Key.fromString "conf_debug"
<*> (v .:?= Key.fromString "conf_debug") <*> v .:?= Key.fromString "conf_layout"
<*> (v .:?= Key.fromString "conf_layout") <*> v .:?= Key.fromString "conf_errorHandling"
<*> (v .:?= Key.fromString "conf_errorHandling") <*> v .:?= Key.fromString "conf_forward"
<*> (v .:?= Key.fromString "conf_forward") <*> v .:?= Key.fromString "conf_preprocessor"
<*> (v .:?= Key.fromString "conf_preprocessor") <*> v .:? Key.fromString "conf_roundtrip_exactprint_only"
<*> (v .:? Key.fromString "conf_roundtrip_exactprint_only") <*> v .:? Key.fromString "conf_disable_formatting"
<*> (v .:? Key.fromString "conf_disable_formatting") <*> v .:? Key.fromString "conf_obfuscate"
<*> (v .:? Key.fromString "conf_obfuscate") parseJSON invalid = Aeson.typeMismatch "Config" invalid
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

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

@ -7,35 +7,48 @@
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 GHC (GenLocated(L))
import qualified GHC hiding (parseModule)
import GHC.Data.Bag
import qualified GHC.Driver.CmdLine as GHC
import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.SrcLoc (Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import 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.Delta as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO import qualified System.IO
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.Types.SrcLoc as GHC
import qualified GHC.Driver.CmdLine as GHC
import GHC.Hs
import GHC.Data.Bag
import GHC.Types.SrcLoc ( SrcSpan, Located )
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
import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
import qualified Data.Generics as SYB
import Control.Exception
-- import Data.Generics.Schemes
parseModule parseModule
:: [String] :: [String]
-> System.IO.FilePath -> System.IO.FilePath
@ -54,7 +67,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))
@ -66,20 +79,17 @@ 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 either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err)))
(\err -> ExceptT.throwE $ "transform error: " ++ show (\(a, m) -> pure (a, m, x))
(bagToList (show <$> err))
)
(\(a, m) -> pure (a, m, x))
$ ExactPrint.postParseTransform res opts $ ExactPrint.postParseTransform res opts
parseModuleFromString parseModuleFromString
@ -97,51 +107,46 @@ 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 -> Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) Right (a , m ) -> pure (a, m, dynCheckRes)
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 let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ const Seq.empty
const Seq.empty `SYB.ext1Q`
`SYB.ext1Q` (\l@(L span _) -> (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l))
Seq.singleton (span, ExactPrint.mkAnnKey l)
)
let nodes = SYB.everything (<>) extract ast let nodes = SYB.everything (<>) extract ast
let let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey annsMap = Map.fromListWith
annsMap = Map.fromListWith (const id)
(const id) [ (GHC.realSrcSpanEnd span, annKey)
[ (GHC.realSrcSpanEnd span, annKey) | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
| (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 let priors = ExactPrint.annPriorComments ann1
priors = ExactPrint.annPriorComments ann1 follows = ExactPrint.annFollowingComments ann1
follows = ExactPrint.annFollowingComments ann1 assocs = ExactPrint.annsDP ann1
assocs = ExactPrint.annsDP ann1
let let
processCom processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos) :: (ExactPrint.Comment, ExactPrint.DeltaPos)
@ -153,32 +158,31 @@ 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 Map.insert annKey2 ann2' anns in
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 let ann1' = ann1 { ExactPrint.annPriorComments = priors'
ann1' = ann1 , ExactPrint.annFollowingComments = follows'
{ ExactPrint.annPriorComments = priors' , ExactPrint.annsDP = assocs'
, ExactPrint.annFollowingComments = follows' }
, ExactPrint.annsDP = assocs'
}
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
@ -266,30 +270,29 @@ 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' groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)
(\m k a -> Map.alter (insert k a) (f k a) m) Map.empty
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 () ()))
@ -298,8 +301,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
@ -309,10 +312,9 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
pure x pure x
where where
f anns = f anns =
let let ((), (annsBalanced, _), _) =
((), (annsBalanced, _), _) = ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) in annsBalanced
in annsBalanced
warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat :: GHC.Warn -> String

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

@ -6,37 +6,50 @@
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 GHC.Types.Name (getOccString) import qualified Control.Monad.Writer.Strict as Writer
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
@ -54,7 +67,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
@ -66,10 +79,9 @@ briDocByExact
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExact ast = do briDocByExact ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf traceIfDumpConf "ast"
"ast" _dconf_dump_ast_unknown
_dconf_dump_ast_unknown (printTreeWithCustom 100 (customLayouterF anns) ast)
(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.
@ -83,10 +95,9 @@ briDocByExactNoComment
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do briDocByExactNoComment ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf traceIfDumpConf "ast"
"ast" _dconf_dump_ast_unknown
_dconf_dump_ast_unknown (printTreeWithCustom 100 (customLayouterF anns) ast)
(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
@ -99,26 +110,24 @@ briDocByExactInlineOnly
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do briDocByExactInlineOnly infoStr ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf traceIfDumpConf "ast"
"ast" _dconf_dump_ast_unknown
_dconf_dump_ast_unknown (printTreeWithCustom 100 (customLayouterF anns) ast)
(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 let exactPrintNode t = allocateNode $ BDFExternal
exactPrintNode t = allocateNode $ BDFExternal (ExactPrint.Types.mkAnnKey ast)
(ExactPrint.Types.mkAnnKey ast) (foldedAnnKeys ast)
(foldedAnnKeys ast) False
False t
t let errorAction = do
let mTell [ErrorUnknownNode infoStr ast]
errorAction = do docLit
mTell [ErrorUnknownNode infoStr ast] $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
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
@ -143,21 +152,20 @@ 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 let hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni x (ExactPrint.Types.G y, _) = x == y hasUni _ _ = False
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)
@ -170,10 +178,9 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
=> Located RdrName => Located RdrName
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let let f x = if x == Text.pack "Data.Type.Equality~"
f x = if x == Text.pack "Data.Type.Equality~" then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh else x
else x
lrdrNameToTextAnnGen f ast lrdrNameToTextAnnGen f ast
-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
@ -191,11 +198,10 @@ 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 let lit = if x == Text.pack "Data.Type.Equality~"
lit = if x == Text.pack "Data.Type.Equality~" then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh else x
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
@ -213,11 +219,12 @@ 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 = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) filterAnns 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
@ -235,16 +242,15 @@ hasCommentsBetween
-> ToBriDocM Bool -> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast mAnn <- astAnn ast
let let go1 [] = False
go1 [] = False go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest go1 (_ : rest) = go1 rest
go1 (_ : rest) = go1 rest go2 [] = False
go2 [] = False go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False go2 (_ : rest) = go2 rest
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
@ -254,8 +260,7 @@ 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 hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
:: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast = hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast any isRegularComment <$> astConnectedComments ast
@ -292,7 +297,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
@ -306,7 +311,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)
@ -455,10 +460,12 @@ 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 = when cond (addAlternative doc) addAlternativeCond cond doc =
when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = CollectAltM . Writer.tell . (: []) addAlternative =
CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) = runFilteredAlternative (CollectAltM action) =
@ -475,8 +482,7 @@ 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 docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
:: 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
@ -511,8 +517,7 @@ docAnnotationKW
-> Maybe AnnKeywordId -> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP docMoveToKWDP
:: AnnKey :: AnnKey
@ -564,7 +569,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 "#)"]
@ -626,26 +631,32 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNodePrior ast bdm = do docWrapNodePrior ast bdm = do
bd <- bdm bd <- bdm
i1 <- allocNodeIndex i1 <- allocNodeIndex
return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd return
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd
docWrapNodeRest ast bdm = do docWrapNodeRest ast bdm = do
bd <- bdm bd <- bdm
i2 <- allocNodeIndex i2 <- allocNodeIndex
return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd return
$ (,) 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
@ -655,25 +666,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
@ -686,7 +697,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
@ -730,7 +741,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
@ -767,15 +778,14 @@ 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 let ((x, errs), debugs) =
((x, errs), debugs) = runIdentity
runIdentity $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1) $ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiReaders readers $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ m
$ 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)

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

@ -3,19 +3,26 @@
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 GHC (GenLocated(L), Located)
import qualified GHC
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.LayouterBasics import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.LayouterBasics
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 ( Located, GenLocated(L) )
import qualified GHC
import GHC.Hs
import Language.Haskell.Brittany.Internal.Layouters.Type
layoutDataDecl layoutDataDecl
:: Located (TyClDecl GhcPs) :: Located (TyClDecl GhcPs)
@ -25,29 +32,28 @@ 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 -> HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
case cons of (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) ->
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) docWrapNode ltycl $ do
-> docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name
nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName
consNameStr <- lrdrNameToTextAnn consName tyVarLine <- return <$> createBndrDoc bndrs
tyVarLine <- return <$> createBndrDoc bndrs -- headDoc <- fmap return $ docSeq
-- headDoc <- fmap return $ docSeq -- [ appSep $ docLitS "newtype")
-- [ appSep $ docLitS "newtype") -- , appSep $ docLit nameStr
-- , appSep $ docLit nameStr -- , appSep tyVarLine
-- , appSep tyVarLine -- ]
-- ] rhsDoc <- return <$> createDetailsDoc consNameStr details
rhsDoc <- return <$> createDetailsDoc consNameStr details createDerivingPar mDerivs $ docSeq
createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "newtype"
[ appSep $ docLitS "newtype" , appSep $ docLit nameStr
, appSep $ docLit nameStr , appSep tyVarLine
, appSep tyVarLine , docSeparator
, docSeparator , docLitS "="
, docLitS "=" , docSeparator
, docSeparator , rhsDoc
, rhsDoc ]
] _ -> briDocByExactNoComment ltycl
_ -> briDocByExactNoComment ltycl
-- data MyData a b -- data MyData a b
@ -55,8 +61,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
@ -68,36 +74,32 @@ 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 <- consDoc <- fmap pure
fmap pure
$ docNonBottomSpacing $ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of $ case (forallDocMay, rhsContextDocMay) of
(Just forallDoc, Just rhsContextDoc) -> docLines (Just forallDoc, Just rhsContextDoc) -> docLines
[ docSeq [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq , docSeq
[ docLitS "." [ docLitS "."
, docSeparator , docSeparator
, docSetBaseY , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
$ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
] ]
(Just forallDoc, Nothing) -> docLines (Just forallDoc, Nothing) -> docLines
[ docSeq [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq [docLitS ".", docSeparator, rhsDoc] , docSeq [docLitS ".", docSeparator, rhsDoc]
] ]
(Nothing, Just rhsContextDoc) -> docSeq (Nothing, Just rhsContextDoc) -> docSeq
@ -105,12 +107,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSeparator , docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
(Nothing, Nothing) -> (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc]
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) $ docSeq [ docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline $ lhsContextDoc , docForceSingleline $ lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -122,13 +124,12 @@ 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 -> Just forallDoc -> docSeq
docSeq [ docForceSingleline forallDoc
[ docForceSingleline forallDoc , docSeparator
, docSeparator , docLitS "."
, docLitS "." , docSeparator
, docSeparator ]
]
, maybe docEmpty docForceSingleline rhsContextDocMay , maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc , rhsDoc
] ]
@ -136,26 +137,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) $ docSeq ( docNodeAnnKW ltycl (Just GHC.AnnData)
$ 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 -> Just forallDoc -> docSeq
docSeq [ docForceSingleline forallDoc
[ docForceSingleline forallDoc , docSeparator
, docSeparator , docLitS "."
, docLitS "." , docSeparator
, docSeparator ]
]
, maybe docEmpty docForceSingleline rhsContextDocMay , maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc , rhsDoc
] ]
@ -166,7 +167,8 @@ 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) $ docSeq ( docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -187,10 +189,13 @@ 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 [appSep $ docLit nameStr, tyVarLine] $ docSeq
[ appSep $ docLit nameStr
, tyVarLine
]
, consDoc , consDoc
] ]
) )
@ -204,20 +209,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 , docForceSingleline $ docSeq $ List.intersperse docCommaSep
docCommaSep (t1Doc : tRDocs)
(t1Doc : tRDocs)
, docLitS ") =>" , docLitS ") =>"
, docSeparator , docSeparator
] ]
, docLines $ join , docLines $ join
[ [docSeq [docLitS "(", docSeparator, t1Doc]] [ [docSeq [docLitS "(", docSeparator, t1Doc]]
, tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] , tRDocs
<&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
, [docLitS ") =>", docSeparator] , [docLitS ") =>", docSeparator]
] ]
] ]
@ -229,18 +234,20 @@ 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 $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> docSeq
case mKind of $ List.intersperse docSeparator
Nothing -> docLit vname $ tyVarDocs
Just kind -> docSeq <&> \(vname, mKind) -> case mKind of
[ docLitS "(" Nothing -> docLit vname
, docLit vname Just kind -> docSeq
, docSeparator [ docLitS "("
, docLitS "::" , docLit vname
, docSeparator , docSeparator
, kind , docLitS "::"
, docLitS ")" , docSeparator
] , kind
, docLitS ")"
]
createDerivingPar createDerivingPar
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -249,47 +256,48 @@ 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)) = derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
case types of (L _ []) -> docSeq []
(L _ []) -> docSeq [] (L _ ts) ->
(L _ ts) -> let
let tsLength = length ts
tsLength = length ts whenMoreThan1Type val =
whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
if tsLength > 1 then docLitS val else docLitS "" (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
(lhsStrategy, rhsStrategy) = in
maybe (docEmpty, docEmpty) strategyLeftRight mStrategy docSeq
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 $ ts <&> \case
<&> \case HsIB _ t -> layoutType t
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", docSeparator, layoutType t] [ docWrapNode lVia $ docLitS " via"
, docSeparator
, layoutType t
]
) )
docDeriving :: ToBriDocM BriDocNumbered docDeriving :: ToBriDocM BriDocNumbered
@ -299,25 +307,21 @@ 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 <- indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
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 $ fmap hsScaledThing args <&> layoutType
<&> layoutType
] ]
leftIndented = leftIndented = docSetParSpacing
docSetParSpacing . docAddBaseY BrIndentRegular
. docAddBaseY BrIndentRegular . docPar (docLit consNameStr)
. docPar (docLit consNameStr) . docLines
. docLines $ layoutType <$> fmap hsScaledThing args
$ layoutType
<$> fmap hsScaledThing args
multiAppended = docSeq multiAppended = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
@ -327,80 +331,79 @@ 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 _ []) -> RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] RecCon lRec@(L _ fields@(_:_)) -> do
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 $ runFilteredAlternative $ do docAddBaseY BrIndentRegular
$ 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
(docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
[ 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]
, docForceSingleline fType
] ]
, docSeq , docSeparator
[ docLitS ","
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName
(docSeq [docLitS "::", docSeparator, fType])
]
]
, docLitS "}" , docLitS "}"
] ]
) addAlternative $ docPar
(docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
[ 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]
, 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
@ -415,11 +418,10 @@ 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 createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
:: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc [] = Nothing
createForallDoc [] = Nothing createForallDoc lhsTyVarBndrs = Just $ docSeq
createForallDoc lhsTyVarBndrs = [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createNamesAndTypeDoc createNamesAndTypeDoc
:: Data.Data.Data ast :: Data.Data.Data ast
@ -429,8 +431,12 @@ 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 $ List.intersperse docCommaSep $ names <&> \case [ docSeq
L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName $ List.intersperse docCommaSep
$ names
<&> \case
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
] ]
, docWrapNodeRest lField $ layoutType t , docWrapNodeRest lField $ layoutType t
) )

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

File diff suppressed because it is too large Load Diff

1233
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,11 +2,20 @@
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,22 +4,26 @@
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.Prelude import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics
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
@ -33,41 +37,36 @@ 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 (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) $ docPar
(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] [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR]
, docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR]
, 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 ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR]
[docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
IEModuleContents _ n -> docSeq IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module" [ docLit $ Text.pack "module"
, docSeparator , docSeparator
@ -76,7 +75,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
@ -93,36 +92,33 @@ 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 :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
-> 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 let sortedLies =
sortedLies = [ items
[ items | group <- Data.List.Extra.groupOn lieToText
| group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies $ List.sortOn lieToText lies
, items <- mergeGroup group , items <- mergeGroup group
] ]
let let ieDocs = fmap layoutIE $ case shouldSort of
ieDocs = fmap layoutIE $ case shouldSort of ShouldSortItems -> sortedLies
ShouldSortItems -> sortedLies KeepItemsUnsorted -> lies
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).
@ -135,22 +131,21 @@ 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 (IEThingWith x
x wn
wn NoIEWildcard
NoIEWildcard (consItems1 ++ consItems2)
(consItems1 ++ consItems2) (fieldLbls1 ++ fieldLbls2)
(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"
@ -169,10 +164,9 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- () -- no comments -- () -- no comments
-- ( -- a comment -- ( -- a comment
-- ) -- )
layoutLLIEs layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
:: 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
@ -182,14 +176,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
@ -197,27 +191,26 @@ 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) = moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)
Text.pack ("@IEModuleContents" ++ moduleNameString name)

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

@ -2,18 +2,26 @@
module Language.Haskell.Brittany.Internal.Layouters.Import where module Language.Haskell.Brittany.Internal.Layouters.Import where
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (GenLocated(L), Located, moduleNameString, unLoc)
import GHC.Hs
import GHC.Types.Basic
import GHC.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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
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(..))
prepPkg :: SourceText -> String prepPkg :: SourceText -> String
prepPkg rawN = case rawN of prepPkg rawN = case rawN of
@ -28,132 +36,111 @@ 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 <- importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> 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 let qualifiedPart = if q /= NotQualified then length "qualified " else 0
qualifiedPart = if q /= NotQualified then length "qualified " else 0 safePart = if safe then length "safe " else 0
safePart = if safe then length "safe " else 0 pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT
pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 }
srcPart = case src of in length "import " + srcPart + safePart + qualifiedPart + pkgPart
IsBoot -> length "{-# SOURCE #-} " qLength = max minQLength qLengthReal
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 , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty }
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 , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty
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 = indentName $ appSep $ docLit modNameT modNameD =
hidDocCol = indentName $ appSep $ docLit modNameT
if hiding then importCol - hidingParenCost else importCol - 2 hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2
hidDocColDiff = importCol - 2 - hidDocCol hidDocColDiff = importCol - 2 - hidDocCol
hidDoc = hidDoc = if hiding
if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty then appSep $ docLit $ Text.pack "hiding"
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 [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies]
[ hidDoc , let makeParIfHiding = if hiding
, 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 (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty])
[hidDoc, docParenLSep, docWrapNode llies docEmpty] (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
) else docSeq [hidDoc, docParenLSep, docSeparator, docParenR]
(docEnsureIndent -- ..[hiding].( b )
(BrIndentSpecial hidDocColDiff) [ieD] -> runFilteredAlternative $ do
docParenR addAlternativeCond (not hasComments)
) $ docSeq
else docSeq [ hidDoc
[hidDoc, docParenLSep, docSeparator, docParenR] , docParenLSep
-- ..[hiding].( b ) , docForceSingleline ieD
[ieD] -> runFilteredAlternative $ do , docSeparator
addAlternativeCond (not hasComments) , docParenR
$ docSeq ]
[ hidDoc addAlternative $ docPar
, docParenLSep (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
, docForceSingleline ieD (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
, docSeparator -- ..[hiding].( b
, docParenR -- , b'
] -- )
addAlternative $ docPar (ieD:ieDs') ->
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD] docPar
) (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]])
(docEnsureIndent ( docEnsureIndent (BrIndentSpecial hidDocColDiff)
(BrIndentSpecial hidDocColDiff) $ docLines
docParenR $ ieDs'
) ++ [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 in docAlt
docAlt [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]
[ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] , docAddBaseY BrIndentRegular $
, docAddBaseY BrIndentRegular docPar (docSeq [importHead, asDoc]) bindingsD
$ docPar (docSeq [importHead, asDoc]) bindingsD ]
] else
else case masT of case masT of
Just n -> if enoughRoom Just n -> if enoughRoom
then docLines [docSeq [importHead, asDoc], bindingsD] then docLines
[ 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 = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) asDoc =
$ makeAsDoc n docEnsureIndent (BrIndentSpecial (importAsCol - asCost))
$ 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,27 +3,34 @@
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.LayouterBasics import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.GHC.ExactPrint as ExactPrint import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..))
import Language.Haskell.GHC.ExactPrint.Types import GHC.Hs
(DeltaPos(..), commentContents, deltaRow) import Language.Haskell.GHC.ExactPrint as ExactPrint
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)
@ -34,38 +41,43 @@ 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 <- allowSingleLineExportList <- mAsk
mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack <&> _conf_layout
.> _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 let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
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 $ docForceSingleline $ docSeq addAlternativeCond allowSingleLine $
[ appSep $ docLit $ Text.pack "module" docForceSingleline
, appSep $ docLit tn $ docSeq
, docWrapNode lmod $ appSep $ case les of [ appSep $ docLit $ Text.pack "module"
Nothing -> docEmpty , appSep $ docLit tn
Just x -> layoutLLIEs True KeepItemsUnsorted x , docWrapNode lmod $ appSep $ case les of
, docSeparator Nothing -> docEmpty
, docLit $ Text.pack "where" Just x -> layoutLLIEs True KeepItemsUnsorted x
] , docSeparator
addAlternative $ docLines , docLit $ Text.pack "where"
]
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 )
[ docWrapNode lmod $ case les of (docSeq [
Nothing -> docEmpty docWrapNode lmod $ case les of
Just x -> layoutLLIEs False KeepItemsUnsorted x Nothing -> docEmpty
, docSeparator Just x -> layoutLLIEs False KeepItemsUnsorted x
, docLit $ Text.pack "where" , docSeparator
] , docLit $ Text.pack "where"
) ]
)
] ]
] ]
: (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]
@ -77,7 +89,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
@ -90,9 +102,8 @@ data ImportStatementRecord = ImportStatementRecord
} }
instance Show ImportStatementRecord where instance Show ImportStatementRecord where
show r = show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show (length $ commentsAfter r)
(length $ commentsAfter r)
transformToCommentedImport transformToCommentedImport
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
@ -110,11 +121,10 @@ transformToCommentedImport is = do
accumF accConnectedComm (annMay, decl) = case annMay of accumF accConnectedComm (annMay, decl) = case annMay of
Nothing -> Nothing ->
( [] ( []
, [ ImportStatement ImportStatementRecord , [ ImportStatement ImportStatementRecord { commentsBefore = []
{ commentsBefore = [] , commentsAfter = []
, commentsAfter = [] , importStatement = decl
, importStatement = decl }
}
] ]
) )
Just ann -> Just ann ->
@ -126,7 +136,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) =
@ -143,8 +153,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
} }
] ]
@ -158,14 +168,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 =
@ -175,23 +185,25 @@ 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 -> docSeq ImportStatement r ->
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) docSeq
( layoutImport (importStatement r)
: map commentToDoc (commentsAfter r)
)
where where
commentToDoc (c, DP (_y, x)) = commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)
docLitS (replicate x ' ' ++ commentContents c)

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

@ -3,19 +3,28 @@
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.LayouterBasics import Language.Haskell.Brittany.Internal.Types
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
@ -29,15 +38,17 @@ import Language.Haskell.Brittany.Internal.Types
-- 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 -> fmap Seq.singleton $ docLit $ lrdrNameToText n VarPat _ n ->
fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr -- abc -> expr
LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit LitPat _ 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
@ -63,9 +74,10 @@ 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 $ sequence $ spacifyDocs $ fmap xR <- fmap Seq.fromList
colsWrapPat $ sequence
argDocs $ spacifyDocs
$ 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
@ -78,7 +90,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
@ -91,34 +103,37 @@ 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 $ fds <&> \case , docSeq $ List.intersperse docCommaSep
(fieldName, Just fieldDoc) -> docSeq $ fds <&> \case
[ appSep $ docLit fieldName (fieldName, Just fieldDoc) -> docSeq
, appSep $ docLit $ Text.pack "=" [ appSep $ docLit fieldName
, fieldDoc >>= colsWrapPat , appSep $ docLit $ Text.pack "="
] , 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 [appSep $ docLit t, docLit $ Text.pack "{..}"] Seq.singleton <$> docSeq
ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) [ appSep $ docLit t
| dotdoti == length fs -> do , docLit $ Text.pack "{..}"
]
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 "="
@ -126,13 +141,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
@ -169,11 +184,10 @@ 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 litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
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
@ -182,7 +196,9 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend wrapPatPrepend
:: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) :: LPat GhcPs
-> 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
@ -204,5 +220,8 @@ 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 [docCommaSep, return bd] rest' <- rest `forM` \bd -> docSeq
[ 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,19 +4,26 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (GenLocated(L))
import GHC.Hs
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Types
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
@ -46,12 +53,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
@ -61,10 +68,9 @@ layoutStmt lstmt@(L _ stmt) = do
f = case indentPolicy of f = case indentPolicy of
IndentPolicyFree -> docSetBaseAndIndent IndentPolicyFree -> docSetBaseAndIndent
IndentPolicyLeft -> docForceSingleline IndentPolicyLeft -> docForceSingleline
IndentPolicyMultiple IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent
| indentFourPlus -> docSetBaseAndIndent | otherwise -> docForceSingleline
| otherwise -> docForceSingleline in f $ return bindDoc
in f $ return bindDoc
] ]
, -- let , -- let
-- bind = expr -- bind = expr
@ -78,11 +84,10 @@ 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 , let f = if indentFourPlus
f = if indentFourPlus then docEnsureIndent BrIndentRegular
then docEnsureIndent BrIndentRegular else docSetBaseAndIndent
else docSetBaseAndIndent in f $ docLines $ return <$> bindDocs
in f $ docLines $ return <$> bindDocs
] ]
-- let -- let
-- aaa = expra -- aaa = expra
@ -90,9 +95,8 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (not indentFourPlus) addAlternativeCond (not indentFourPlus)
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar (docLit $ Text.pack "let")
(docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
(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,7 +2,14 @@
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,18 +3,28 @@
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 Language.Haskell.Brittany.Internal.Types import qualified Data.Text as Text
import Language.Haskell.Brittany.Internal.Utils import qualified GHC.OldList as List
(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
@ -22,66 +32,76 @@ 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 -> IsPromoted -> docSeq
docSeq [docSeparator, docTick, docWrapNode name $ docLit t] [ docSeparator
, 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 let maybeForceML = case typ2 of
maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline
(L _ HsFunTy{}) -> docForceMultiline _ -> id
_ -> id
let let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt forallDoc = docAlt
[ let open = docLit $ Text.pack "forall" [ let
in docSeq ([open] ++ tyVarDocLineList) open = docLit $ Text.pack "forall"
in docSeq ([open]++tyVarDocLineList)
, docPar , docPar
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines $ tyVarDocs <&> \case (docLines
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname $ tyVarDocs <&> \case
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
[ docCols ColTyOpPrefix [docParenLSep, docLit tname] (tname, Just doc) -> docEnsureIndent BrIndentRegular
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] $ docLines
, docLit $ Text.pack ")" [ docCols ColTyOpPrefix
] [ 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 = List.intersperse docCommaSep
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close]) in docSeq ([open]++list++[close])
, let , let
open = docCols open = docCols ColTyOpPrefix
ColTyOpPrefix [ docParenLSep
[ docParenLSep , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs ]
]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols list = List.tail cntxtDocs <&> \cntxtDoc ->
ColTyOpPrefix docCols ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] [ docCommaSep
, 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 else let
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
@ -91,74 +111,75 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b -- => a b
-- -> c -- -> c
, docPar , docPar
forallDoc forallDoc
(docLines ( docLines
[ docCols [ docCols ColTyOpPrefix
ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " , docAddBaseY (BrIndentSpecial 3)
, docAddBaseY (BrIndentSpecial 3) $ contextDoc $ 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 let maybeForceML = case typ2 of
maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline
(L _ HsFunTy{}) -> docForceMultiline _ -> id
_ -> 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 else let
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 ( docCols ColTyOpPrefix
ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " , maybeForceML $ return typeDoc
, 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) -> (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
docEnsureIndent BrIndentRegular $ docLit tname (tname, Just doc) -> docEnsureIndent BrIndentRegular
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname] [ docCols ColTyOpPrefix
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] [ docParenLSep
, docLit $ Text.pack ")" , docLit tname
]
, 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
@ -169,27 +190,29 @@ 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 = List.intersperse docCommaSep
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close]) in docSeq ([open]++list++[close])
, let , let
open = docCols open = docCols ColTyOpPrefix
ColTyOpPrefix [ docParenLSep
[ docParenLSep , docAddBaseY (BrIndentSpecial 2)
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs $ head cntxtDocs
] ]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols list = List.tail cntxtDocs <&> \cntxtDoc ->
ColTyOpPrefix docCols ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] [ docCommaSep
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
let let maybeForceML = case typ1 of
maybeForceML = case typ1 of (L _ HsFunTy{}) -> docForceMultiline
(L _ HsFunTy{}) -> docForceMultiline _ -> id
_ -> id
docAlt docAlt
-- (Foo a b c) => a b -> c -- (Foo a b c) => a b -> c
[ docSeq [ docSeq
@ -201,39 +224,37 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b -- => a b
-- -> c -- -> c
, docPar , docPar
(docForceSingleline contextDoc) (docForceSingleline contextDoc)
(docCols ( docCols ColTyOpPrefix
ColTyOpPrefix [ docLit $ Text.pack "=> "
[ docLit $ Text.pack "=> " , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
, 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 let maybeForceML = case typ2 of
maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline
(L _ HsFunTy{}) -> docForceMultiline _ -> id
_ -> 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
] ]
++ [ docPar | not hasComments
(docNodeAnnKW ltype Nothing typeDoc1) ] ++
(docCols [ docPar
ColTyOpPrefix (docNodeAnnKW ltype Nothing typeDoc1)
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" ( docCols ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
] , docAddBaseY (BrIndentSpecial 3)
) $ maybeForceML typeDoc2
] ]
)
]
HsParTy _ typ1 -> do HsParTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
@ -243,28 +264,24 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
, docPar , docPar
(docCols ( docCols ColTyOpPrefix
ColTyOpPrefix [ docWrapNodeRest ltype $ docParenLSep
[ docWrapNodeRest ltype $ docParenLSep , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 ])
] (docLit $ Text.pack ")")
)
(docLit $ Text.pack ")")
] ]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather gather list = \case
:: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1
gather list = \case final -> (final, list)
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 $ docForceSingleline docHead : (docRest >>= \d ->
: (docRest >>= \d -> [docSeparator, docForceSingleline d]) [ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
] ]
HsAppTy _ typ1 typ2 -> do HsAppTy _ typ1 typ2 -> do
@ -276,7 +293,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docSeparator , docSeparator
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
] ]
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) , docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
] ]
HsListTy _ typ1 -> do HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
@ -287,61 +306,51 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
, docPar , docPar
(docCols ( docCols ColTyOpPrefix
ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ " , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
, 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 unboxed = if null typs then error "brittany internal error: unboxed unit"
then error "brittany internal error: unboxed unit" else unboxedL
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 let end = docLit $ Text.pack ")"
end = docLit $ Text.pack ")" lines = List.tail docs <&> \d ->
lines = docAddBaseY (BrIndentSpecial 2)
List.tail docs $ docCols ColTyOpPrefix [docCommaSep, d]
<&> \d -> docAddBaseY (BrIndentSpecial 2) commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt docAlt
[ docSeq [ docSeq $ [docLit $ Text.pack "("]
$ [docLit $ Text.pack "("] ++ docWrapNodeRest ltype commaDocs
++ docWrapNodeRest ltype commaDocs ++ [end]
++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in in docPar
docPar (docAddBaseY (BrIndentSpecial 2) $ line1)
(docAddBaseY (BrIndentSpecial 2) $ line1) (docLines $ docWrapNodeRest ltype lines ++ [end])
(docLines $ docWrapNodeRest ltype lines ++ [end])
] ]
unboxedL = do unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let let start = docParenHashLSep
start = docParenHashLSep end = docParenHashRSep
end = docParenHashRSep
docAlt docAlt
[ docSeq [ docSeq $ [start]
$ [start] ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) ++ [end]
++ [end]
, let , let
line1 = docCols ColTyOpPrefix [start, head docs] line1 = docCols ColTyOpPrefix [start, head docs]
lines = lines = List.tail docs <&> \d ->
List.tail docs docAddBaseY (BrIndentSpecial 2)
<&> \d -> docAddBaseY (BrIndentSpecial 2) $ docCols ColTyOpPrefix [docCommaSep, d]
$ docCols ColTyOpPrefix [docCommaSep, d]
in docPar in docPar
(docAddBaseY (BrIndentSpecial 2) line1) (docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ lines ++ [end]) (docLines $ lines ++ [end])
@ -410,18 +419,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack [ docWrapNodeRest ltype
("?" ++ showSDocUnsafe (ftext ipName) ++ "::") $ docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
] ]
, docPar , docPar
(docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) ( docLit
(docCols $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
ColTyOpPrefix )
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: " (docCols ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) typeDoc1 [ docWrapNodeRest ltype
] $ docLit $ Text.pack ":: "
) , docAddBaseY (BrIndentSpecial 2) typeDoc1
])
] ]
-- TODO: test KindSig -- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do HsKindSig _ typ1 kind1 -> do
@ -462,7 +473,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
@ -533,7 +544,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
@ -558,23 +569,19 @@ 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 ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
++ [docLit $ Text.pack " ]"] ++ [docLit $ Text.pack " ]"]
addAlternative addAlternative $
$ let let
start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] start = docCols ColList
linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] [appSep $ docLit $ Text.pack "'[", e1]
lineN = docCols linesM = ems <&> \d ->
ColList docCols ColList [specialCommaSep, d]
[specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] lineN = docCols ColList [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
@ -585,7 +592,8 @@ 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 _ -> docLit $ Text.pack "_" HsWildCardTy _ ->
docLit $ Text.pack "_"
HsSumTy{} -> -- TODO HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do HsStarTy _ isUnicode -> do
@ -598,12 +606,14 @@ 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 t (docSeq [docLit $ Text.pack "@", k]) , docPar
t
(docSeq [docLit $ Text.pack "@", k ])
] ]
layoutTyVarBndrs layoutTyVarBndrs

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

@ -2,24 +2,28 @@
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 Language.Haskell.Brittany.Internal.PreludeUtils import Data.Char
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 let exceptionFilter x | x `elem` keywords = False
exceptionFilter x | x `elem` keywords = False exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x | x `elem` extraKWs = False exceptionFilter x = not $ null $ drop 1 x
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
@ -71,14 +75,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,195 +1,346 @@
module Language.Haskell.Brittany.Internal.Prelude module Language.Haskell.Brittany.Internal.Prelude ( module E ) where
( 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(..))
import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) -- rather project-specific stuff:
import Control.Concurrent as E (forkIO, forkOS, threadDelay) ---------------------------------
import Control.Concurrent.Chan as E (Chan) import GHC.Hs.Extension as E ( GhcPs )
import Control.Concurrent.MVar as E
(MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) import GHC.Types.Name.Reader as E ( RdrName )
import Control.Exception as E (assert, bracket, evaluate)
import Control.Monad as E
( (<$!>) -- more general:
, (<=<) ----------------
, (=<<)
, (>=>) import Data.Functor.Identity as E ( Identity(..) )
, Functor(..) import Control.Concurrent.Chan as E ( Chan )
, Monad(..) import Control.Concurrent.MVar as E ( MVar
, MonadPlus(..) , newEmptyMVar
, filterM , newMVar
, forM , putMVar
, forM_ , readMVar
, forever , takeMVar
, guard , swapMVar
, join )
, liftM import Data.Int as E ( Int )
, liftM2 import Data.Word as E ( Word
, liftM3 , Word32
, liftM4 )
, liftM5 import Prelude as E ( Integer
, mapM , Float
, mapM_ , Double
, replicateM , undefined
, replicateM_ , Eq (..)
, sequence , Ord (..)
, sequence_ , Enum (..)
, unless , Bounded (..)
, void , (<$>)
, when , (.)
) , ($)
import Control.Monad.Extra as E , ($!)
(allM, andM, anyM, ifM, notM, orM, unlessM, whenM) , Num (..)
import Control.Monad.IO.Class as E (MonadIO(..)) , Integral (..)
import Control.Monad.ST as E (ST) , Fractional (..)
import Control.Monad.Trans.Class as E (lift) , Floating (..)
import Control.Monad.Trans.Maybe as E (MaybeT(..)) , RealFrac (..)
import Control.Monad.Trans.MultiRWS as E , RealFloat (..)
(MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) , fromIntegral
import Data.Bifunctor as E (bimap) , error
import Data.Bool as E (Bool(..)) , foldr
import Data.Char as E (Char, chr, ord) , foldl
import Data.Data as E (toConstr) , foldr1
import Data.Either as E (Either(..), either) , id
import Data.Foldable as E (asum, fold, foldl', foldr') , map
import Data.Function as E ((&), fix) , subtract
import Data.Functor as E (($>)) , putStrLn
import Data.Functor.Identity as E (Identity(..)) , putStr
import Data.IORef as E (IORef) , Show (..)
import Data.Int as E (Int) , print
import Data.List as E , fst
( all , snd
, break , (++)
, drop , not
, dropWhile , (&&)
, elem , (||)
, filter , curry
, find , uncurry
, intercalate , flip
, intersperse , const
, isPrefixOf , seq
, isSuffixOf , reverse
, iterate , otherwise
, length , traverse
, mapAccumL , realToFrac
, mapAccumR , or
, maximum , and
, minimum , head
, notElem , any
, nub , (^)
, null , Foldable
, partition , Traversable
, repeat )
, replicate import Control.Monad.ST as E ( ST )
, sortBy import Data.Bool as E ( Bool(..) )
, sum import Data.Char as E ( Char
, take , ord
, takeWhile , chr
, transpose )
, uncons import Data.Either as E ( Either(..)
, unzip , either
, zip )
, zip3 import Data.IORef as E ( IORef )
, zipWith import Data.Maybe as E ( Maybe(..)
) , fromMaybe
import Data.List.Extra as E (nubOrd, stripSuffix) , maybe
import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) , listToMaybe
import Data.Map as E (Map) , maybeToList
import Data.Maybe as E , catMaybes
(Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) )
import Data.Monoid as E import Data.Monoid as E ( Endo(..)
( All(..) , All(..)
, Alt(..) , Any(..)
, Any(..) , Sum(..)
, Endo(..) , Product(..)
, Monoid(..) , Alt(..)
, Product(..) , mconcat
, Sum(..) , Monoid (..)
, mconcat )
) import Data.Ord as E ( Ordering(..)
import Data.Ord as E (Down(..), Ordering(..), comparing) , Down(..)
import Data.Proxy as E (Proxy(..)) , comparing
import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) )
import Data.Semigroup as E ((<>), Semigroup(..)) import Data.Ratio as E ( Ratio
import Data.Sequence as E (Seq) , Rational
import Data.Set as E (Set) , (%)
import Data.String as E (String) , numerator
import Data.Text as E (Text) , denominator
import Data.Tree as E (Tree(..)) )
import Data.Tuple as E (swap) import Data.String as E ( String )
import Data.Typeable as E (Typeable) import Data.Void as E ( Void )
import Data.Version as E (showVersion) import System.IO as E ( IO
import Data.Void as E (Void) , hFlush
import Data.Word as E (Word, Word32) , stdout
import Debug.Trace as E )
( trace import Data.Proxy as E ( Proxy(..) )
, traceIO import Data.Sequence as E ( Seq )
, traceId
, traceM import Data.Map as E ( Map )
, traceShow import Data.Set as E ( Set )
, traceShowId
, traceShowM import Data.Text as E ( Text )
, 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 Prelude as E import Data.Foldable as E ( foldl'
( ($) , foldr'
, ($!) , fold
, (&&) , asum
, (++) )
, (.)
, (<$>) import Data.List as E ( partition
, Bounded(..) , null
, Double , elem
, Enum(..) , notElem
, Eq(..) , minimum
, Float , maximum
, Floating(..) , length
, Foldable , all
, Fractional(..) , take
, Integer , drop
, Integral(..) , find
, Num(..) , sum
, Ord(..) , zip
, RealFloat(..) , zip3
, RealFrac(..) , zipWith
, Show(..) , repeat
, Traversable , replicate
, (^) , iterate
, and , nub
, any , filter
, const , intersperse
, curry , intercalate
, error , isSuffixOf
, flip , isPrefixOf
, foldl , dropWhile
, foldr , takeWhile
, foldr1 , unzip
, fromIntegral , break
, fst , transpose
, head , sortBy
, id , mapAccumL
, map , mapAccumR
, not , uncons
, or )
, otherwise
, print import Data.List.NonEmpty as E ( NonEmpty(..)
, putStr , nonEmpty
, putStrLn )
, realToFrac
, reverse import Data.Tuple as E ( swap
, seq )
, snd
, subtract import Text.Read as E ( readMaybe
, traverse )
, uncurry
, undefined import Control.Monad as E ( Functor (..)
, (||) , Monad (..)
) , MonadPlus (..)
import System.IO as E (IO, hFlush, stdout) , mapM
import Text.Read as E (readMaybe) , mapM_
, 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,15 +1,21 @@
{-# 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 Control.Exception.Base (evaluate) import Prelude
import Control.Monad
import qualified Data.Strict.Maybe as Strict import qualified Data.Strict.Maybe as Strict
import Debug.Trace import Debug.Trace
import Prelude import Control.Monad
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)
@ -24,12 +30,12 @@ instance Alternative Strict.Maybe where
x <|> Strict.Nothing = x x <|> Strict.Nothing = x
_ <|> x = x _ <|> x = x
traceFunctionWith traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
:: 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 = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y traceStr =
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 (<$!>)
@ -45,10 +51,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

1411
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,10 +3,16 @@
module Language.Haskell.Brittany.Internal.Transformations.Columns where module Language.Haskell.Brittany.Internal.Transformations.Columns where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
transformSimplifyColumns :: BriDoc -> BriDoc transformSimplifyColumns :: BriDoc -> BriDoc
transformSimplifyColumns = Uniplate.rewrite $ \case transformSimplifyColumns = Uniplate.rewrite $ \case
@ -14,150 +20,118 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
-- BDWrapAnnKey annKey $ transformSimplify bd -- BDWrapAnnKey annKey $ transformSimplify bd
BDEmpty -> Nothing BDEmpty -> Nothing
BDLit{} -> Nothing BDLit{} -> Nothing
BDSeq list BDSeq list | any (\case BDSeq{} -> True
| any BDEmpty{} -> True
(\case _ -> False) list -> Just $ BDSeq $ list >>= \case
BDSeq{} -> True BDEmpty -> []
BDEmpty{} -> True BDSeq l -> l
_ -> False x -> [x]
) BDSeq (BDCols sig1 cols1@(_:_):rest)
list | all (\case BDSeparator -> True; _ -> False) rest ->
-> Just $ BDSeq $ list >>= \case Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)])
BDEmpty -> [] BDLines lines | any (\case BDLines{} -> True
BDSeq l -> l BDEmpty{} -> True
x -> [x] _ -> False) lines ->
BDSeq (BDCols sig1 cols1@(_ : _) : rest) Just $ BDLines $ filter isNotEmpty $ lines >>= \case
| 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 Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) -> BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]
$ 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 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) | sig1==sig2 ->
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, sig1 == sig2 -> Just | BDCols sig1 _ <- List.last lines1
$ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) , sig1==sig2 ->
BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
| BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest))
$ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) | BDCols sig1 _ <- List.last lines1
, 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 BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols
| BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 , sig1==sig2 ->
-> Just Just $ BDLines
$ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] [ BDCols sig1 (List.init cols ++ [line])
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
] ]
BDLines [x] -> Just $ x BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols
BDLines [] -> Just $ BDEmpty , BDCols sig2 cols2 <- List.last lines
BDSeq{} -> Nothing , sig1==sig2 ->
BDCols{} -> Nothing Just $ BDLines
BDSeparator -> Nothing [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)]
BDAddBaseY{} -> Nothing , BDCols sig2 cols2
BDBaseYPushCur{} -> Nothing ]
BDBaseYPop{} -> Nothing BDLines [x] -> Just $ x
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,20 +3,25 @@
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 Language.Haskell.Brittany.Internal.Types import qualified GHC.OldList as List
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) = mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)
BrIndentSpecial (max i j) mergeIndents _ _ = error "mergeIndents"
mergeIndents _ _ = error "mergeIndents"
transformSimplifyFloating :: BriDoc -> BriDoc transformSimplifyFloating :: BriDoc -> BriDoc
@ -26,192 +31,169 @@ 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 Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDSeq BDAnnotationRest annKey1 (BDLines list) ->
$ List.init list Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDCols sig cols) ->
BDAnnotationRest annKey1 (BDLines list) -> Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
Just BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
$ BDLines Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
$ List.init list BDAnnotationRest annKey1 (BDDebug s x) ->
++ [BDAnnotationRest annKey1 $ List.last list] Just $ BDDebug s $ BDAnnotationRest annKey1 x
BDAnnotationRest annKey1 (BDCols sig cols) -> _ -> Nothing
Just descendKW = transformDownMay $ \case
$ BDCols sig -- post floating in
$ List.init cols BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
++ [BDAnnotationRest annKey1 $ List.last cols] Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
BDAnnotationRest annKey1 (BDAddBaseY indent x) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationRest annKey1 (BDDebug s x) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDDebug s $ BDAnnotationRest annKey1 x Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
_ -> Nothing BDAnnotationKW annKey1 kw (BDCols sig cols) ->
descendKW = transformDownMay $ \case Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]
-- post floating in BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
BDAnnotationKW annKey1 kw (BDPar ind line indented) -> Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented BDAnnotationKW annKey1 kw (BDDebug s x) ->
BDAnnotationKW annKey1 kw (BDSeq list) -> Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
Just _ -> Nothing
$ BDSeq descendBYPush = transformDownMay $ \case
$ List.init list BDBaseYPushCur (BDCols sig cols@(_:_)) ->
++ [BDAnnotationKW annKey1 kw $ List.last list] Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDAnnotationKW annKey1 kw (BDLines list) -> BDBaseYPushCur (BDDebug s x) ->
Just Just $ BDDebug s (BDBaseYPushCur x)
$ BDLines _ -> Nothing
$ List.init list descendBYPop = transformDownMay $ \case
++ [BDAnnotationKW annKey1 kw $ List.last list] BDBaseYPop (BDCols sig cols@(_:_)) ->
BDAnnotationKW annKey1 kw (BDCols sig cols) -> Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
Just BDBaseYPop (BDDebug s x) ->
$ BDCols sig Just $ BDDebug s (BDBaseYPop x)
$ List.init cols _ -> Nothing
++ [BDAnnotationKW annKey1 kw $ List.last cols] descendILPush = transformDownMay $ \case
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> BDIndentLevelPushCur (BDCols sig cols@(_:_)) ->
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDAnnotationKW annKey1 kw (BDDebug s x) -> BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x Just $ BDDebug s (BDIndentLevelPushCur x)
_ -> Nothing _ -> Nothing
descendBYPush = transformDownMay $ \case descendILPop = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_ : _)) -> BDIndentLevelPop (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) BDIndentLevelPop (BDDebug s x) ->
_ -> Nothing Just $ BDDebug s (BDIndentLevelPop x)
descendBYPop = transformDownMay $ \case _ -> Nothing
BDBaseYPop (BDCols sig cols@(_ : _)) -> descendAddB = transformDownMay $ \case
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) BDAddBaseY BrIndentNone x ->
BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) Just x
_ -> Nothing -- AddIndent floats into Lines.
descendILPush = transformDownMay $ \case BDAddBaseY indent (BDLines lines) ->
BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just Just $ BDLines $ BDAddBaseY indent <$> lines
$ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) -- AddIndent floats into last column
BDIndentLevelPushCur (BDDebug s x) -> BDAddBaseY indent (BDCols sig cols) ->
Just $ BDDebug s (BDIndentLevelPushCur x) Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
_ -> Nothing -- merge AddIndent and Par
descendILPop = transformDownMay $ \case BDAddBaseY ind1 (BDPar ind2 line indented) ->
BDIndentLevelPop (BDCols sig cols@(_ : _)) -> Just $ BDPar (mergeIndents ind1 ind2) line indented
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
_ -> Nothing BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
descendAddB = transformDownMay $ \case Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
BDAddBaseY BrIndentNone x -> Just x BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
-- AddIndent floats into Lines. Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY indent (BDLines lines) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDLines $ BDAddBaseY indent <$> lines Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
-- AddIndent floats into last column BDAddBaseY _ lit@BDLit{} ->
BDAddBaseY indent (BDCols sig cols) -> Just $ lit
Just BDAddBaseY ind (BDBaseYPushCur x) ->
$ BDCols sig Just $ BDBaseYPushCur (BDAddBaseY ind x)
$ List.init cols BDAddBaseY ind (BDBaseYPop x) ->
++ [BDAddBaseY indent $ List.last cols] Just $ BDBaseYPop (BDAddBaseY ind x)
-- merge AddIndent and Par BDAddBaseY ind (BDDebug s x) ->
BDAddBaseY ind1 (BDPar ind2 line indented) -> Just $ BDDebug s (BDAddBaseY ind x)
Just $ BDPar (mergeIndents ind1 ind2) line indented BDAddBaseY ind (BDIndentLevelPop x) ->
BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> Just $ BDIndentLevelPop (BDAddBaseY ind x)
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) BDAddBaseY ind (BDIndentLevelPushCur x) ->
BDAddBaseY ind (BDAnnotationRest annKey1 x) -> Just $ BDIndentLevelPushCur (BDAddBaseY ind x)
Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) BDAddBaseY ind (BDEnsureIndent ind2 x) ->
BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> Just $ BDEnsureIndent (mergeIndents ind ind2) x
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) _ -> Nothing
BDAddBaseY ind (BDSeq list) -> stepBO :: BriDoc -> BriDoc
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
BDAddBaseY _ lit@BDLit{} -> Just $ lit transformUp f
BDAddBaseY ind (BDBaseYPushCur x) -> where
Just $ BDBaseYPushCur (BDAddBaseY ind x) f = \case
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) x@BDAnnotationPrior{} -> descendPrior x
BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) x@BDAnnotationKW{} -> descendKW x
BDAddBaseY ind (BDIndentLevelPop x) -> x@BDAnnotationRest{} -> descendRest x
Just $ BDIndentLevelPop (BDAddBaseY ind x) x@BDAddBaseY{} -> descendAddB x
BDAddBaseY ind (BDIndentLevelPushCur x) -> x@BDBaseYPushCur{} -> descendBYPush x
Just $ BDIndentLevelPushCur (BDAddBaseY ind x) x@BDBaseYPop{} -> descendBYPop x
BDAddBaseY ind (BDEnsureIndent ind2 x) -> x@BDIndentLevelPushCur{} -> descendILPush x
Just $ BDEnsureIndent (mergeIndents ind ind2) x x@BDIndentLevelPop{} -> descendILPop x
_ -> Nothing x -> x
stepBO :: BriDoc -> BriDoc stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ Uniplate.rewrite $ \case
transformUp f BDAddBaseY BrIndentNone x ->
where Just $ x
f = \case -- AddIndent floats into Lines.
x@BDAnnotationPrior{} -> descendPrior x BDAddBaseY indent (BDLines lines) ->
x@BDAnnotationKW{} -> descendKW x Just $ BDLines $ BDAddBaseY indent <$> lines
x@BDAnnotationRest{} -> descendRest x -- AddIndent floats into last column
x@BDAddBaseY{} -> descendAddB x BDAddBaseY indent (BDCols sig cols) ->
x@BDBaseYPushCur{} -> descendBYPush x Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
x@BDBaseYPop{} -> descendBYPop x BDAddBaseY ind (BDSeq list) ->
x@BDIndentLevelPushCur{} -> descendILPush x Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
x@BDIndentLevelPop{} -> descendILPop x -- merge AddIndent and Par
x -> x BDAddBaseY ind1 (BDPar ind2 line indented) ->
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ Just $ BDPar (mergeIndents ind1 ind2) line indented
Uniplate.rewrite $ \case BDAddBaseY _ lit@BDLit{} ->
BDAddBaseY BrIndentNone x -> Just $ x Just $ lit
-- AddIndent floats into Lines. BDAddBaseY ind (BDBaseYPushCur x) ->
BDAddBaseY indent (BDLines lines) -> Just $ BDBaseYPushCur (BDAddBaseY ind x)
Just $ BDLines $ BDAddBaseY indent <$> lines BDAddBaseY ind (BDBaseYPop x) ->
-- AddIndent floats into last column Just $ BDBaseYPop (BDAddBaseY ind x)
BDAddBaseY indent (BDCols sig cols) -> -- prior floating in
Just BDAnnotationPrior annKey1 (BDPar ind line indented) ->
$ BDCols sig Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
$ List.init cols BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->
++ [BDAddBaseY indent $ List.last cols] Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr)
BDAddBaseY ind (BDSeq list) -> BDAnnotationPrior annKey1 (BDLines (l:lr)) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDLines ((BDAnnotationPrior annKey1 l):lr)
-- merge AddIndent and Par BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
BDAddBaseY ind1 (BDPar ind2 line indented) -> Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr)
Just $ BDPar (mergeIndents ind1 ind2) line indented -- EnsureIndent float-in
BDAddBaseY _ lit@BDLit{} -> Just $ lit -- BDEnsureIndent indent (BDCols sig (col:colr)) ->
BDAddBaseY ind (BDBaseYPushCur x) -> -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
Just $ BDBaseYPushCur (BDAddBaseY ind x) -- not sure if the following rule is necessary; tests currently are
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) -- unaffected.
-- prior floating in -- BDEnsureIndent indent (BDLines lines) ->
BDAnnotationPrior annKey1 (BDPar ind line indented) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented -- post floating in
BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationPrior annKey1 (BDLines (l : lr)) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
-- EnsureIndent float-in BDAnnotationRest annKey1 (BDCols sig cols) ->
-- BDEnsureIndent indent (BDCols sig (col:colr)) -> Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) _ -> Nothing
-- 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,10 +3,16 @@
module Language.Haskell.Brittany.Internal.Transformations.Indent where module Language.Haskell.Brittany.Internal.Transformations.Indent where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- 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
@ -25,17 +31,15 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x -- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented -- , BDEnsureIndent ind indented
-- ] -- ]
BDLines lines BDLines lines | any ( \case
| any BDLines{} -> True
(\case BDEmpty{} -> True
BDLines{} -> True _ -> False
BDEmpty{} -> True )
_ -> False lines ->
) 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)
@ -49,4 +53,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,9 +3,14 @@
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
@ -19,28 +24,25 @@ 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 BDLines lines | any ( \case
| any BDLines{} -> True
(\case BDEmpty{} -> True
BDLines{} -> True _ -> False
BDEmpty{} -> True )
_ -> False lines -> case go lines of
) [] -> BDEmpty
lines [x] -> x
-> case go lines of xs -> BDLines xs
[] -> 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

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

@ -12,47 +12,52 @@
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 Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict 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 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
data PerItemConfig = PerItemConfig data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe) { _icd_perBinding :: Map String (CConfig Maybe)
, _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)
} }
deriving Data.Data.Data deriving Data.Data.Data
type PPM type PPM = MultiRWSS.MultiRWS
= MultiRWSS.MultiRWS '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
'[ Map ExactPrint.AnnKey ExactPrint.Anns '[Text.Builder.Builder, [BrittanyError], Seq String]
, PerItemConfig '[]
, Config
, ExactPrint.Anns
]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[]
type PPMLocal type PPMLocal = MultiRWSS.MultiRWS
= MultiRWSS.MultiRWS '[Config, ExactPrint.Anns]
'[Config , ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String]
'[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
@ -60,7 +65,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.
@ -73,14 +78,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
@ -110,21 +115,14 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
instance Show LayoutState where instance Show LayoutState where
show state = show state =
"LayoutState" "LayoutState"
++ "{baseYs=" ++ "{baseYs=" ++ show (_lstate_baseYs state)
++ show (_lstate_baseYs state) ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
++ ",curYOrAddNewline=" ++ ",indLevels=" ++ show (_lstate_indLevels state)
++ show (_lstate_curYOrAddNewline state) ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
++ ",indLevels=" ++ ",commentCol=" ++ show (_lstate_commentCol state)
++ show (_lstate_indLevels state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
++ ",indLevelLinger=" ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state)
++ 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
@ -225,16 +223,14 @@ data BrIndent = BrIndentNone
| BrIndentSpecial Int | BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show) deriving (Eq, Ord, Data.Data.Data, Show)
type ToBriDocM type ToBriDocM = MultiRWSS.MultiRWS
= MultiRWSS.MultiRWS '[Config, Anns] -- reader
'[Config , Anns] -- reader '[[BrittanyError], Seq String] -- writer
'[[BrittanyError] , Seq String] -- writer '[NodeAllocIndex] -- state
'[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
= Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered type ToBriDocC sym c = Located sym -> ToBriDocM c
type ToBriDocC sym c = Located sym -> ToBriDocM c
data DocMultiLine data DocMultiLine
= MultiLineNo = MultiLineNo
@ -342,21 +338,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) =
@ -365,84 +361,83 @@ 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 -> BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
briDocSeqSpine line `seq` briDocSeqSpine indented BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts BDForwardLineMode bd -> briDocSeqSpine bd
BDForwardLineMode bd -> briDocSeqSpine bd BDExternal{} -> ()
BDExternal{} -> () BDPlain{} -> ()
BDPlain{} -> () BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationRest _annKey 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
@ -461,19 +456,18 @@ data VerticalSpacingPar
-- product like (Normal|Always, None|Some Int). -- product like (Normal|Always, None|Some Int).
deriving (Eq, Show) deriving (Eq, Show)
data VerticalSpacing = VerticalSpacing data VerticalSpacing
{ _vs_sameLine :: !Int = VerticalSpacing
, _vs_paragraph :: !VerticalSpacingPar { _vs_sameLine :: !Int
, _vs_parFlag :: !Bool , _vs_paragraph :: !VerticalSpacingPar
} , _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 = pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
LineModeValidity (Strict.Just x) :: LineModeValidity t pattern LineModeInvalid :: forall t. LineModeValidity t
pattern LineModeInvalid :: forall t . LineModeValidity t pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
pattern LineModeInvalid =
LineModeValidity Strict.Nothing :: LineModeValidity t

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

@ -7,29 +7,40 @@
module Language.Haskell.Brittany.Internal.Utils where module Language.Haskell.Brittany.Internal.Utils where
import qualified Data.ByteString as B
import qualified Data.Coerce
import Data.Data
import Data.Generics.Aliases
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import DataTreePrint
import qualified GHC.Data.FastString as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Hs.Extension as HsExtension
import qualified GHC.OldList as List
import GHC.Types.Name.Occurrence as OccName (occNameString)
import 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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import qualified Data.Coerce
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified GHC.OldList as List
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
@ -44,8 +55,7 @@ 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 = fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce 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 =
@ -60,26 +70,24 @@ 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 instance Show ShowIsId where show (ShowIsId x) = x
show (ShowIsId x) = x
data A x = A ShowIsId x data A x = A ShowIsId x deriving Data
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
@ -87,22 +95,18 @@ 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 = occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = srcSpan ss = simpleLayouter
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
@ -114,12 +118,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
@ -127,15 +131,14 @@ 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 = occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
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
@ -199,11 +202,12 @@ 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 (Seq String) m => String -> m () tellDebugMess :: MonadMultiWriter
(Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow tellDebugMessShow :: forall a m . (MonadMultiWriter
:: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () (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..
@ -218,28 +222,29 @@ 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 = annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
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 (bs, cs) = breakEither fn aR where
(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 (ys, xs) = spanMaybe f xR where
spanMaybe _ xs = ([], xs) (ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)
data FirstLastView a data FirstLastView a
= FirstLastEmpty = FirstLastEmpty
@ -249,7 +254,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`
@ -268,7 +273,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,41 +4,58 @@
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 GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Obfuscation
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Paths_brittany
import qualified System.Directory as Directory
import qualified System.Exit
import qualified System.FilePath.Posix as FilePath
import qualified System.IO import qualified System.IO
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Text.PrettyPrint as PP import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Text.Read (Read(..)) import qualified Data.Monoid
import UI.Butcher.Monadic
import GHC ( GenLocated(L) )
import GHC.Utils.Outputable ( Outputable(..)
, showSDocUnsafe
)
import Text.Read ( Read(..) )
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.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany
data WriteMode = Display | Inplace data WriteMode = Display | Inplace
@ -93,7 +110,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"
] ]
@ -130,16 +147,15 @@ 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"]
["config-file"] "PATH"
"PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? cmdlineConfig <- cmdlineConfigParser
cmdlineConfig <- cmdlineConfigParser
suppressOutput <- addSimpleBoolFlag suppressOutput <- addSimpleBoolFlag
"" ""
["suppress-output"] ["suppress-output"]
@ -165,7 +181,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!)"
@ -195,13 +211,11 @@ mainCmdParser helpDesc = do
$ ppHelpShallow helpDesc $ ppHelpShallow helpDesc
System.Exit.exitSuccess System.Exit.exitSuccess
let let inputPaths =
inputPaths = if null inputParams then [Nothing] else map Just inputParams
if null inputParams then [Nothing] else map Just inputParams let outputPaths = case writeMode of
let Display -> repeat Nothing
outputPaths = case writeMode of Inplace -> inputPaths
Display -> repeat Nothing
Inplace -> inputPaths
configsToLoad <- liftIO $ if null configPaths configsToLoad <- liftIO $ if null configPaths
then then
@ -216,15 +230,14 @@ 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 results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode)
(coreIO putStrErrLn config suppressOutput checkMode) inputPaths
inputPaths outputPaths
outputPaths
if checkMode if checkMode
then when (Changes `elem` (Data.Either.rights results)) then when (Changes `elem` (Data.Either.rights results))
@ -253,65 +266,58 @@ 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 let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
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 let hackAroundIncludes =
hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack let exactprintOnly = viaGlobal || viaDebug
let where
exactprintOnly = viaGlobal || viaDebug viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
where viaDebug =
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags then case cppMode of
then case cppMode of CPPModeAbort -> do
CPPModeAbort -> do return $ Left "Encountered -XCPP. Aborting."
return $ Left "Encountered -XCPP. Aborting." CPPModeWarn -> do
CPPModeWarn -> do putErrorLnIO
putErrorLnIO $ "Warning: Encountered -XCPP."
$ "Warning: Encountered -XCPP." ++ " Be warned that -XCPP is not supported and that"
++ " Be warned that -XCPP is not supported and that" ++ " brittany cannot check that its output is syntactically"
++ " brittany cannot check that its output is syntactically" ++ " valid in its presence."
++ " valid in its presence." return $ Right True
return $ Right True CPPModeNowarn -> return $ Right True
CPPModeNowarn -> return $ Right True else return $ Right False
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 let hackF s = if "#include" `isPrefixOf` s
hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s
then "-- BRITANY_INCLUDE_HACK " ++ s else s
else s let hackTransform = if hackAroundIncludes && not exactprintOnly
let then List.intercalate "\n" . fmap hackF . lines'
hackTransform = if hackAroundIncludes && not exactprintOnly else id
then List.intercalate "\n" . fmap hackF . lines'
else id
inputString <- liftIO System.IO.getContents inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString parseRes <- liftIO $ parseModuleFromString ghcOptions
ghcOptions "stdin"
"stdin" cppCheckFunc
cppCheckFunc (hackTransform inputString)
(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
@ -340,12 +346,10 @@ 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 let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return () trace ("---- ast ----\n" ++ show val) $ return ()
let let disableFormatting =
disableFormatting = moduleConf & _conf_disable_formatting & confUnpack
moduleConf & _conf_disable_formatting & confUnpack
(errsWarns, outSText, hasChanges) <- do (errsWarns, outSText, hasChanges) <- do
if if
| disableFormatting -> do | disableFormatting -> do
@ -354,52 +358,46 @@ 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 let omitCheck =
omitCheck = moduleConf
moduleConf & _conf_errorHandling
& _conf_errorHandling .> _econf_omit_output_valid_check
.> _econf_omit_output_valid_check .> confUnpack
.> 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 else liftIO $ pPrintModuleAndCheck moduleConf
moduleConf perItemConf
perItemConf anns
anns parsedSource
parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix
let (TextL.pack "-- BRITANY_INCLUDE_HACK ")
hackF s = fromMaybe s $ TextL.stripPrefix s
(TextL.pack "-- BRITANY_INCLUDE_HACK ") let out = TextL.toStrict $ if hackAroundIncludes
s then
let TextL.intercalate (TextL.pack "\n")
out = TextL.toStrict $ if hackAroundIncludes $ hackF
then <$> TextL.splitOn (TextL.pack "\n") outRaw
TextL.intercalate (TextL.pack "\n") else outRaw
$ 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 let customErrOrder ErrorInput{} = 4
customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorMacroConfig{} = 5
customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do unless (null errsWarns) $ do
let let groupedErrsWarns =
groupedErrsWarns = Data.List.Extra.groupOn customErrOrder
Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder
$ List.sortOn customErrOrder $ errsWarns
$ 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
@ -408,10 +406,9 @@ 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 putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc)
(ppr loc)
when when
(config ( config
& _conf_debug & _conf_debug
& _dconf_dump_ast_unknown & _dconf_dump_ast_unknown
& confUnpack & confUnpack
@ -425,17 +422,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
@ -446,8 +443,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
@ -462,11 +459,10 @@ 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 let isIdentical = case inputPathM of
isIdentical = case inputPathM of Nothing -> False
Nothing -> False Just _ -> not hasChanges
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
@ -478,15 +474,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,24 +2,35 @@
{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
import Data.Coerce (coerce) import Language.Haskell.Brittany.Internal.Prelude
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 Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified System.Directory import qualified System.Directory
import System.FilePath ((</>))
import System.Timeout (timeout) import Test.Hspec
import Test.Hspec
import qualified Text.Parsec as Parsec import qualified Text.Parsec as Parsec
import Text.Parsec.Text (Parser) 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
hush :: Either a b -> Maybe b hush :: Either a b -> Maybe b
hush = either (const Nothing) Just hush = either (const Nothing) Just
@ -29,32 +40,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] <&> \(i :: Int) -> ( [1 .. 10]
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") <&> \(i :: Int) ->
(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 action = fmap (fmap PPTextWrapper)
(fmap PPTextWrapper) (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
data InputLine data InputLine
@ -74,11 +85,10 @@ data TestCase = TestCase
main :: IO () main :: IO ()
main = do main = do
files <- System.Directory.listDirectory "data/" files <- System.Directory.listDirectory "data/"
let let blts =
blts = List.sort
List.sort $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) $ filter (".blt" `isSuffixOf`) files
$ 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"
@ -89,17 +99,15 @@ 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
let [ "func ="
expected = Text.pack $ unlines , " [ 00000000000000000000000"
[ "func =" , " , 00000000000000000000000"
, " [ 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
@ -146,33 +154,30 @@ 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 in TestCase
TestCase { testName = n
{ testName = n , isPending = any isPendingLine rest
, isPending = any isPendingLine rest , content = Text.unlines normalLines
, content = Text.unlines normalLines }
}
l -> l ->
error error $ "first non-empty line must start with #test footest\n" ++ show l
$ "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"
@ -192,17 +197,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
-------------------- --------------------
@ -220,42 +225,43 @@ 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
} }
} }