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

Format Brittany with Brittany

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

5
brittany.yaml Normal file
View File

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

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

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

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

@ -12,68 +12,52 @@ module Language.Haskell.Brittany.Internal
, parseModuleFromString
, extractCommentConfigs
, getTopLevelDeclNameMap
)
where
) where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Control.Monad.Trans.Except
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.ByteString.Char8
import Data.CZipWith
import Data.Char (isSpace)
import Data.HList.HList
import qualified Data.Map as Map
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL
import qualified GHC.OldList as List
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import Control.Monad.Trans.Except
import Data.HList.HList
import qualified Data.Yaml
import 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 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 Data.Char ( isSpace )
import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.SrcLoc (SrcSpan)
import Language.Haskell.Brittany.Internal.Backend
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Indent
import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified UI.Butcher.Monadic as Butcher
data InlineConfigTarget
= InlineConfigTargetModule
@ -91,7 +75,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
[ ( k
, [ x
| (ExactPrint.Comment x _ _, _) <-
( ExactPrint.annPriorComments ann
(ExactPrint.annPriorComments ann
++ ExactPrint.annFollowingComments ann
)
]
@ -102,7 +86,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
)
| (k, ann) <- Map.toList anns
]
let configLiness = commentLiness <&> second
let
configLiness = commentLiness <&> second
(Data.Maybe.mapMaybe $ \line -> do
l1 <-
List.stripPrefix "-- BRITTANY" line
@ -112,7 +97,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
let l2 = dropWhile isSpace l1
guard
( ("@" `isPrefixOf` l2)
(("@" `isPrefixOf` l2)
|| ("-disable" `isPrefixOf` l2)
|| ("-next" `isPrefixOf` l2)
|| ("{" `isPrefixOf` l2)
@ -138,19 +123,22 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
]
parser = do -- we will (mis?)use butcher here to parse the inline config
-- line.
let nextDecl = do
let
nextDecl = do
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
Butcher.addCmd "-next-declaration" nextDecl
Butcher.addCmd "-Next-Declaration" nextDecl
Butcher.addCmd "-NEXT-DECLARATION" nextDecl
let nextBinding = do
let
nextBinding = do
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
Butcher.addCmd "-next-binding" nextBinding
Butcher.addCmd "-Next-Binding" nextBinding
Butcher.addCmd "-NEXT-BINDING" nextBinding
let disableNextBinding = do
let
disableNextBinding = do
Butcher.addCmdImpl
( InlineConfigTargetNextBinding
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
@ -158,7 +146,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
Butcher.addCmd "-disable-next-binding" disableNextBinding
Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
let disableNextDecl = do
let
disableNextDecl = do
Butcher.addCmdImpl
( InlineConfigTargetNextDecl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
@ -166,7 +155,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
Butcher.addCmd "-disable-next-declaration" disableNextDecl
Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
let disableFormatting = do
let
disableFormatting = do
Butcher.addCmdImpl
( InlineConfigTargetModule
, mempty { _conf_disable_formatting = pure $ pure True }
@ -188,31 +178,32 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
Right c -> Right $ c
pure (k, r)
let perModule = foldl'
let
perModule = foldl'
(<>)
mempty
[ conf
| (_ , lineConfigs) <- lineConfigss
, (InlineConfigTargetModule, conf ) <- lineConfigs
| (_, lineConfigs) <- lineConfigss
, (InlineConfigTargetModule, conf) <- lineConfigs
]
let
perBinding = Map.fromListWith
(<>)
[ (n, conf)
| (k , lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs
| (k, lineConfigs) <- lineConfigss
, (target, conf) <- lineConfigs
, n <- case target of
InlineConfigTargetBinding s -> [s]
InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
[name]
InlineConfigTargetNextBinding
| Just name <- Map.lookup k declNameMap -> [name]
_ -> []
]
let
perKey = Map.fromListWith
(<>)
[ (k, conf)
| (k , lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs
| (k, lineConfigs) <- lineConfigss
, (target, conf) <- lineConfigs
, case target of
InlineConfigTargetNextDecl -> True
InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->
@ -248,20 +239,24 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
-- won't do.
parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule configWithDebugs inputText = runExceptT $ do
let config =
let
config =
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
(anns, parsedSource, hasCPP) <- do
let hackF s = if "#include" `isPrefixOf` s
let
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s
else s
let hackTransform = if hackAroundIncludes
let
hackTransform = if hackAroundIncludes
then List.intercalate "\n" . fmap hackF . lines'
else id
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
let
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True
@ -285,7 +280,8 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
return inputText
else do
(errsWarns, outputTextL) <- do
let omitCheck =
let
omitCheck =
moduleConfig
& _conf_errorHandling
& _econf_omit_output_valid_check
@ -294,23 +290,26 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
then return $ pPrintModule moduleConfig perItemConf anns parsedSource
else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
let hackF s = fromMaybe s
let
hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes
then
( ews
, TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn
(TextL.pack "\n")
outRaw
, TextL.intercalate (TextL.pack "\n")
$ hackF
<$> TextL.splitOn (TextL.pack "\n") outRaw
)
else (ews, outRaw)
let customErrOrder ErrorInput{} = 4
let
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5
let hasErrors =
let
hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns)
@ -331,7 +330,8 @@ pPrintModule
-> GHC.ParsedSource
-> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule =
let ((out, errs), debugStrings) =
let
((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
@ -367,11 +367,13 @@ pPrintModuleAndCheck
pPrintModuleAndCheck conf inlineConf anns parsedModule = do
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
let (errs, output) = pPrintModule conf inlineConf anns parsedModule
parseResult <- parseModuleFromString ghcOptions
parseResult <- parseModuleFromString
ghcOptions
"output"
(\_ -> return $ Right ())
(TextL.unpack output)
let errs' = errs ++ case parseResult of
let
errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck]
Right{} -> []
return (errs', output)
@ -384,14 +386,18 @@ parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
case parseResult of
Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
Left err ->
return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
Right (anns, parsedModule) -> runExceptT $ do
(inlineConf, perItemConf) <-
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
case
extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule)
of
Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x
let moduleConf = cZipWith fromOptionIdentity conf inlineConf
let omitCheck =
let
omitCheck =
conf
& _conf_errorHandling
.> _econf_omit_output_valid_check
@ -468,23 +474,26 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
let mBindingConfs =
let
mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
filteredAnns <- mAsk
<&> \annMap ->
Map.union (Map.findWithDefault Map.empty annKey annMap) $
Map.findWithDefault Map.empty declAnnKey annMap
filteredAnns <- mAsk <&> \annMap ->
Map.union (Map.findWithDefault Map.empty annKey annMap)
$ Map.findWithDefault Map.empty declAnnKey annMap
traceIfDumpConf "bridoc annotations filtered/transformed"
traceIfDumpConf
"bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns
config <- mAsk
let config' = cZipWith fromOptionIdentity config
let
config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
let
exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do
bd <- if exactprintOnly
then briDocMToPPM $ briDocByExactNoComment decl
@ -497,7 +506,8 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd
let finalComments = filter
let
finalComments = filter
(fst .> \case
ExactPrint.AnnComment{} -> True
_ -> False
@ -508,10 +518,10 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr
(ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
ExactPrint.AnnComment cm
| span <- ExactPrint.commentIdentifier cm
-> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
let
folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
)
_ -> (acc + y, x)
@ -540,7 +550,8 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
-- attached annotations that come after the module's where
-- from the module node
config <- mAsk
let shouldReformatPreamble =
let
shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let
@ -558,15 +569,15 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
eofInd = List.findIndex (isEof . fst) modAnnsDp
(pre, post') = case (whereInd, eofInd) of
(Nothing, Nothing) -> ([], modAnnsDp)
(Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp
(Just i, Nothing) -> List.splitAt (i + 1) 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 }
filteredAnns'' =
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
in
(filteredAnns'', post')
traceIfDumpConf "bridoc annotations filtered/transformed"
in (filteredAnns'', post')
traceIfDumpConf
"bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns'
@ -612,7 +623,8 @@ layoutBriDoc briDoc = do
mGet >>= transformSimplifyFloating .> mSet
mGet
>>= briDocToDoc
.> traceIfDumpConf "bridoc post-floating"
.> traceIfDumpConf
"bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
-- bridoc transformation: par removal
mGet >>= transformSimplifyPar .> mSet
@ -638,7 +650,9 @@ layoutBriDoc briDoc = do
anns :: ExactPrint.Anns <- mAsk
let state = LayoutState { _lstate_baseYs = [0]
let
state = LayoutState
{ _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-- here because moveToAnn stuff
-- of the first node needs to do
@ -653,7 +667,8 @@ layoutBriDoc briDoc = do
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let remainingComments =
let
remainingComments =
[ c
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
(_lstate_comments state')

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

@ -6,10 +6,6 @@
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 Data.Either as Either
import qualified Data.Foldable as Foldable
@ -21,22 +17,18 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.Brittany.Internal.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
@ -45,8 +37,12 @@ data ColumnSpacing
type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
type ColMap1
= IntMapL.IntMap {- ColIndex -}
(Bool, ColumnBlocks ColumnSpacing)
type ColMap2
= IntMapL.IntMap {- ColIndex -}
(Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw)
data ColInfo
@ -56,15 +52,18 @@ data ColInfo
instance Show ColInfo where
show ColInfoStart = "ColInfoStart"
show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
show (ColInfoNo bd) =
"ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
show (ColInfo ind sig list) =
"ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1
, _cbs_index :: ColIndex
}
type LayoutConstraints m = ( MonadMultiReader Config m
type LayoutConstraints m
= ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
@ -90,7 +89,8 @@ layoutBriDocM = \case
BDSeparator -> do
layoutAddSepSpace
BDAddBaseY indent bd -> do
let indentF = case indent of
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
@ -108,7 +108,8 @@ layoutBriDocM = \case
layoutBriDocM bd
layoutIndentLevelPop
BDEnsureIndent indent bd -> do
let indentF = case indent of
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
@ -117,7 +118,8 @@ layoutBriDocM = \case
layoutBriDocM bd
BDPar indent sameLine indented -> do
layoutBriDocM sameLine
let indentF = case indent of
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
@ -126,12 +128,13 @@ layoutBriDocM = \case
layoutBriDocM indented
BDLines lines -> alignColsLines lines
BDAlt [] -> error "empty BDAlt"
BDAlt (alt:_) -> layoutBriDocM alt
BDAlt (alt : _) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n"
let
tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do
@ -154,7 +157,8 @@ layoutBriDocM = \case
BDAnnotationPrior annKey bd -> do
state <- mGet
let m = _lstate_comments state
let moveToExactLocationAction = case _lstate_curYOrAddNewline state of
let
moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure ()
Right{} -> moveToExactAnn annKey
mAnn <- do
@ -176,7 +180,8 @@ layoutBriDocM = \case
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment
case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)
('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
-- ^ evil hack for CPP
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
@ -192,14 +197,16 @@ layoutBriDocM = \case
state <- mGet
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of
let
mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just
annR
Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
Just annR
_ -> Nothing
case mToSpan of
Just anns -> do
let (comments, rest) = flip spanMaybe anns $ \case
let
(comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state
@ -213,12 +220,14 @@ layoutBriDocM = \case
case mComments of
Nothing -> pure ()
Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)
('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
@ -232,18 +241,23 @@ layoutBriDocM = \case
let m = _lstate_comments state
pure $ Map.lookup annKey m
let mComments = nonEmpty . extractAllComments =<< annMay
let semiCount = length [ ()
| Just ann <- [ annMay ]
let
semiCount = length
[ ()
| 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
{ _lstate_comments = Map.adjust
( \ann -> ann { ExactPrint.annFollowingComments = []
(\ann -> ann
{ ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = []
, ExactPrint.annsDP =
flip filter (ExactPrint.annsDP ann) $ \case
, ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False
_ -> True
}
@ -254,13 +268,14 @@ layoutBriDocM = \case
case mComments of
Nothing -> do
when shouldAddSemicolonNewlines $ do
[1..semiCount] `forM_` const layoutWriteNewline
[1 .. semiCount] `forM_` const layoutWriteNewline
Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack comment
case comment of
('#':_) -> layoutMoveToCommentPos y (-999) 1
('#' : _) -> layoutMoveToCommentPos y (-999) 1
-- ^ evil hack for CPP
")" -> pure ()
-- ^ fixes the formatting of parens
@ -276,7 +291,9 @@ layoutBriDocM = \case
state <- mGet
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let relevant = [ dp
let
relevant =
[ dp
| Just ann <- [mAnn]
, (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1
@ -284,7 +301,7 @@ layoutBriDocM = \case
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
case relevant of
[] -> pure Nothing
(ExactPrint.Types.DP (y, x):_) -> do
(ExactPrint.Types.DP (y, x) : _) -> do
mSet state { _lstate_commentNewlines = 0 }
pure $ Just (y - _lstate_commentNewlines state, x)
case mDP of
@ -367,7 +384,7 @@ briDocIsMultiLine briDoc = rec briDoc
BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd
BDLines (_ : _ : _) -> True
BDLines [_ ] -> False
BDLines [_] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
@ -484,18 +501,20 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
where alignMax' = max 0 alignMax
processedMap :: ColMap2
processedMap =
fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->
processedMap = fix $ \result ->
_cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let
colss = colSpacingss <&> \spss -> case reverse spss of
[] -> []
(xN:xR) ->
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
(xN : xR) ->
reverse
$ (if lastFlag then fLast else fInit) xN
: fmap fInit xR
where
fLast (ColumnSpacingLeaf len ) = len
fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = {-Foldable.foldl1 maxZipper-}
@ -507,8 +526,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
else count
ratio = fromIntegral (foldl counter (0 :: Int) colss)
/ fromIntegral (length colss)
in
(ratio, maxCols, colss)
in (ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
@ -516,7 +534,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
mergeBriDocsW
:: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do
mergeBriDocsW lastInfo (bd : bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW
-- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
@ -545,8 +563,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- personal preference to not break alignment for those, even if
-- multiline. Really, this should be configurable.. (TODO)
shouldBreakAfter :: BriDoc -> Bool
shouldBreakAfter bd = alignBreak &&
briDocIsMultiLine bd && case bd of
shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of
(BDCols ColTyOpPrefix _) -> False
(BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncInfix _) -> True
@ -578,11 +595,10 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case
brdc@(BDCols colSig subDocs)
| infoSig == colSig && length subLengthsInfos == length subDocs
-> do
| infoSig == colSig && length subLengthsInfos == length subDocs -> do
let
isLastList = if lastFlag
then (==length subDocs) <$> [1 ..]
then (== length subDocs) <$> [1 ..]
else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
@ -599,15 +615,15 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
m
}
return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise
-> briDocToColInfo lastFlag brdc
| otherwise -> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList =
if lastFlag then (==length list) <$> [1 ..] else repeat False
let
isLastList =
if lastFlag then (== length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
@ -617,7 +633,7 @@ briDocToColInfo lastFlag = \case
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _ ) -> ColumnSpacingLeaf len
(len, _) -> ColumnSpacingLeaf len
withAlloc
:: Bool
@ -641,7 +657,8 @@ processInfo maxSpace m = \case
ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
do
colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
alignMode <-
mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do
state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
@ -654,7 +671,8 @@ processInfo maxSpace m = \case
let colMax = min colMaxConf (curX + maxSpace)
-- tellDebugMess $ show curX
let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
let maxCols2 = list <&> \case
let
maxCols2 = list <&> \case
(_, ColInfo i _ _) ->
let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l
@ -668,8 +686,9 @@ processInfo maxSpace m = \case
-- 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
-- forced to occupy the full vertical space, not reduced by any factor.
let fixedPosXs = case alignMode of
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)
let
fixedPosXs = case alignMode of
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)
where
factor :: Float =
-- 0.0001 as an offering to the floating point gods.
@ -677,17 +696,18 @@ processInfo maxSpace m = \case
1.0001
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
offsets = (subtract curX) <$> posXs
fixed = offsets <&> fromIntegral .> (*factor) .> truncate
fixed = offsets <&> fromIntegral .> (* factor) .> truncate
_ -> posXs
let spacings = zipWith (-)
(List.tail fixedPosXs ++ [min maxX colMax])
fixedPosXs
let
spacings =
zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs
-- tellDebugMess $ "ind = " ++ show ind
-- tellDebugMess $ "maxCols = " ++ show maxCols
-- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
-- tellDebugMess $ "list = " ++ show list
-- tellDebugMess $ "maxSpace = " ++ show maxSpace
let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
let
alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
layoutWriteEnsureAbsoluteN destX
processInfo s m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore)

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

@ -3,42 +3,29 @@
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.Either
import qualified Data.Map as Map
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey
, Annotation
)
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import GHC (Located)
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import GHC ( Located )
traceLocal
:: (MonadMultiState LayoutState m)
=> a
-> m ()
traceLocal :: (MonadMultiState LayoutState m) => a -> m ()
traceLocal _ = return ()
layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Text
-> m ()
layoutWriteAppend t = do
@ -60,9 +47,7 @@ layoutWriteAppend t = do
}
layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
-> m ()
layoutWriteAppendSpaces i = do
@ -70,20 +55,18 @@ layoutWriteAppendSpaces i = do
unless (i == 0) $ do
state <- mGet
mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
{ _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state
}
layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> [Text]
-> m ()
layoutWriteAppendMultiline ts = do
traceLocal ("layoutWriteAppendMultiline", ts)
case ts of
[] -> layoutWriteAppend (Text.pack "") -- need to write empty, too.
(l:lr) -> do
(l : lr) -> do
layoutWriteAppend l
lr `forM_` \x -> do
layoutWriteNewline
@ -91,14 +74,13 @@ layoutWriteAppendMultiline ts = do
-- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> m ()
layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock")
state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1
mSet $ state
{ _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state
}
@ -116,11 +98,11 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state
-- }
layoutSetCommentCol
:: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol :: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol = do
state <- mGet
let col = case _lstate_curYOrAddNewline state of
let
col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col)
@ -130,9 +112,7 @@ layoutSetCommentCol = do
-- This is also used to move to non-comments in a couple of places. Seems
-- to be harmless so far..
layoutMoveToCommentPos
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
-> Int
-> Int
@ -150,8 +130,7 @@ layoutMoveToCommentPos y x commentLines = do
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x
else if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol =
Just $ case _lstate_commentCol state of
, _lstate_commentCol = Just $ case _lstate_commentCol state of
Just existing -> existing
Nothing -> case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
@ -162,9 +141,7 @@ layoutMoveToCommentPos y x commentLines = do
-- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> m ()
layoutWriteNewline = do
traceLocal ("layoutWriteNewline")
@ -181,9 +158,7 @@ _layoutResetCommentNewlines = do
mModify $ \state -> state { _lstate_commentNewlines = 0 }
layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> m ()
layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock")
@ -197,61 +172,53 @@ layoutWriteEnsureNewlineBlock = do
}
layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
-> m ()
layoutWriteEnsureAbsoluteN n = do
state <- mGet
let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
(Just c , _ ) -> n - c
(Nothing, Left i ) -> n - i
let
diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
(Just c, _) -> n - c
(Nothing, Left i) -> n - i
(Nothing, Right{}) -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
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
-- overwrite any old value in any
-- bad way.
}
layoutBaseYPushInternal
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()
layoutBaseYPushInternal i = do
traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutBaseYPopInternal
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPopInternal = do
traceLocal ("layoutBaseYPopInternal")
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
layoutIndentLevelPushInternal
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
:: (MonadMultiState LayoutState m) => Int -> m ()
layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
mModify $ \s -> s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
mModify $ \s -> s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s
}
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m ()
layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m ()
layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
}
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }
layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m
@ -283,9 +250,7 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal
layoutWithAddBaseColNBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
-> m ()
-> m ()
@ -298,27 +263,23 @@ layoutWithAddBaseColNBlock amount m = do
layoutBaseYPopInternal
layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> m ()
layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock")
state <- mGet
let
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
(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)
-- when (diff>0) $ layoutWriteNewlineBlock
when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
-> m ()
-> m ()
@ -328,39 +289,36 @@ layoutWithAddBaseColN amount m = do
m
layoutBaseYPopInternal
layoutBaseYPushCur
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur")
state <- mGet
case _lstate_commentCol state of
Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
(Left i, Just j) -> layoutBaseYPushInternal (i + j)
(Left i, Nothing) -> layoutBaseYPushInternal i
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do
traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal
layoutIndentLevelPushCur
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur")
state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> i + j
(Left i , Nothing) -> i
(Right{}, Just j ) -> j
let
y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> i + j
(Left i, Nothing) -> i
(Right{}, Just j) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y
layoutIndentLevelPop
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop")
layoutIndentLevelPopInternal
@ -370,12 +328,12 @@ layoutIndentLevelPop = do
-- make sense.
layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m)
=> m ()
layoutAddSepSpace :: (MonadMultiState LayoutState m) => m ()
layoutAddSepSpace = do
state <- mGet
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
-- can probably be removed.
@ -399,16 +357,16 @@ moveToExactAnn annKey = do
moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of
let
upd = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in state
in
state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then
_lstate_commentCol state
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
(lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
@ -421,9 +379,7 @@ moveToY y = mModify $ \state ->
-- else x
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.DeltaPos
-> m ()
:: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " "
@ -443,17 +399,18 @@ layoutWritePriorComments ast = do
let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annPriorComments = [] })
key
anns
}
return mAnn
case mAnn of
Nothing -> return ()
Just priors -> do
unless (null priors) $ layoutSetCommentCol
priors `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y)
) -> do
priors
`forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
@ -462,10 +419,13 @@ layoutWritePriorComments ast = do
-- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..".
layoutWritePostComments :: (Data.Data.Data ast,
MonadMultiWriter Text.Builder.Builder m,
MonadMultiState LayoutState m)
=> Located ast -> m ()
layoutWritePostComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Located ast
-> m ()
layoutWritePostComments ast = do
mAnn <- do
state <- mGet
@ -473,8 +433,8 @@ layoutWritePostComments ast = do
let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annFollowingComments = [] })
key
anns
}
@ -483,30 +443,28 @@ layoutWritePostComments ast = do
Nothing -> return ()
Just posts -> do
unless (null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y)
) -> do
posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
do
replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' '
mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment
:: ( MonadMultiState LayoutState m
, MonadMultiWriter Text.Builder.Builder m
)
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
=> m ()
layoutIndentRestorePostComment = do
state <- mGet
let mCommentCol = _lstate_commentCol state
let eCurYAddNL = _lstate_curYOrAddNewline state
mModify $ \s -> s { _lstate_commentCol = Nothing
, _lstate_commentNewlines = 0
}
mModify
$ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 }
case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe
0
(_lstate_addSepSpace state)
_ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,

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

@ -3,38 +3,27 @@
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.ByteString as ByteString
import qualified Data.ByteString.Char8
import qualified Data.Semigroup as Semigroup
import qualified GHC.OldList as List
import qualified System.Directory
import qualified System.IO
import qualified Data.Yaml
import Data.CZipWith
import UI.Butcher.Monadic
import qualified System.Console.CmdArgs.Explicit
as CmdArgs
import Data.Coerce (coerce)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup as Semigroup
import qualified Data.Yaml
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Utils
import Data.Coerce ( coerce
)
import qualified Data.List.NonEmpty as NonEmpty
import qualified System.Console.CmdArgs.Explicit as CmdArgs
import qualified System.Directory
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified System.IO
import UI.Butcher.Monadic
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
staticDefaultConfig :: Config
staticDefaultConfig = Config
{ _conf_version = coerce (1 :: Int)
@ -105,7 +94,7 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions
]
}
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 }
-- brittany-next-binding --columns 200
cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe)
cmdlineConfigParser = do
-- TODO: why does the default not trigger; ind never should be []!!
@ -245,7 +234,8 @@ userConfigPath = do
userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"
userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
let searchDirs = [userBritPathSimple, userBritPathXdg]
globalConfig <- Directory.findFileWith Directory.doesFileExist
globalConfig <- Directory.findFileWith
Directory.doesFileExist
searchDirs
"config.yaml"
maybe (writeUserConfig userBritPathXdg) pure globalConfig
@ -271,8 +261,9 @@ readConfigs
-> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths
let merged = Semigroup.sconcat
$ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
let
merged =
Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs

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

@ -7,24 +7,15 @@
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.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 (Identity x) = coerce x
@ -43,7 +34,7 @@ data CDebugConfig f = DebugConfig
, _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)
, _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
}
deriving (Generic)
deriving Generic
data CLayoutConfig f = LayoutConfig
{ _lconfig_cols :: f (Last Int) -- the thing that has default 80.
@ -148,12 +139,12 @@ data CLayoutConfig f = LayoutConfig
-- -- > , y :: Double
-- -- > }
}
deriving (Generic)
deriving Generic
data CForwardOptions f = ForwardOptions
{ _options_ghc :: f [String]
}
deriving (Generic)
deriving Generic
data CErrorHandlingConfig f = ErrorHandlingConfig
{ _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
@ -168,13 +159,13 @@ data CErrorHandlingConfig f = ErrorHandlingConfig
-- has different semantics than the code pre-transformation.
, _econf_omit_output_valid_check :: f (Semigroup.Last Bool)
}
deriving (Generic)
deriving Generic
data CPreProcessorConfig f = PreProcessorConfig
{ _ppconf_CPPMode :: f (Semigroup.Last CPPMode)
, _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)
}
deriving (Generic)
deriving Generic
data CConfig f = Config
{ _conf_version :: f (Semigroup.Last Int)
@ -194,9 +185,8 @@ data CConfig f = Config
-- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something
-- in that direction).
, _conf_obfuscate :: f (Semigroup.Last Bool)
}
deriving (Generic)
deriving Generic
type DebugConfig = CDebugConfig Identity
type LayoutConfig = CLayoutConfig Identity

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

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

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

@ -7,47 +7,34 @@
module Language.Haskell.Brittany.Internal.ExactPrintUtils where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Control.Exception
import qualified Control.Monad.State.Class as State.Class
import qualified Control.Monad.Trans.Except as ExceptT
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.Data
import qualified Data.Foldable as Foldable
import qualified Data.Generics as SYB
import Data.HList.HList
import qualified Data.Map as Map
import qualified Data.Maybe
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import 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 GHC (GenLocated(L))
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 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.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
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO
parseModule
:: [String]
@ -88,7 +75,10 @@ parseModuleWithCpp cpp opts args fp dynCheck =
++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err)))
either
(\err -> ExceptT.throwE $ "transform error: " ++ show
(bagToList (show <$> err))
)
(\(a, m) -> pure (a, m, x))
$ ExactPrint.postParseTransform res opts
@ -121,19 +111,23 @@ parseModuleFromString args fp dynCheck str =
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of
Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
Right (a , m ) -> pure (a, m, dynCheckRes)
Left err ->
ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
Right (a, m) -> pure (a, m, dynCheckRes)
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
let
extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
const Seq.empty
`SYB.ext1Q`
(\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l))
`SYB.ext1Q` (\l@(L span _) ->
Seq.singleton (span, ExactPrint.mkAnnKey l)
)
let nodes = SYB.everything (<>) extract ast
let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
let
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith
(const id)
[ (GHC.realSrcSpanEnd span, annKey)
@ -144,7 +138,8 @@ commentAnnFixTransformGlob ast = do
processComs annsMap annKey1 = do
mAnn <- State.Class.gets fst <&> Map.lookup annKey1
mAnn `forM_` \ann1 -> do
let priors = ExactPrint.annPriorComments ann1
let
priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let
@ -171,15 +166,16 @@ commentAnnFixTransformGlob ast = do
{ ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair]
}
in
Map.insert annKey2 ann2' anns
in Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node.
priors' <- filterM processCom priors
follows' <- filterM processCom follows
assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True
let ann1' = ann1 { ExactPrint.annPriorComments = priors'
let
ann1' = ann1
{ ExactPrint.annPriorComments = priors'
, ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs'
}
@ -274,7 +270,8 @@ extractToplevelAnns lmod anns = output
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)
groupMap f = Map.foldlWithKey'
(\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty
where
insert k a Nothing = Just (Map.singleton k a)
@ -283,16 +280,16 @@ groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = SYB.everything
Set.union
( \x -> maybe
(\x -> maybe
Set.empty
Set.singleton
[ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
]
-- for some reason, ghc-8.8 has forgotten how to infer the type of l,
-- even though it is passed to mkAnnKey above, which only accepts
-- SrcSpan.
]
)
ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
@ -301,8 +298,8 @@ foldedAnnKeys ast = SYB.everything
withTransformedAnns
:: Data 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
readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS
@ -312,7 +309,8 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
pure x
where
f anns =
let ((), (annsBalanced, _), _) =
let
((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced

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

@ -6,50 +6,37 @@
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.Writer.Strict as Writer
import qualified Data.Char as Char
import Data.Data
import qualified Data.Map as Map
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import DataTreePrint
import GHC (GenLocated(L), Located, moduleName, moduleNameString)
import qualified GHC.OldList as List
import qualified Control.Monad.Writer.Strict as Writer
import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.Name (getOccString)
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Types.Name.Reader (RdrName(..))
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
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
:: ( ExactPrint.Annotate.Annotate ast
, MonadMultiWriter Text.Builder.Builder m
@ -79,7 +66,8 @@ briDocByExact
-> ToBriDocM BriDocNumbered
briDocByExact ast = do
anns <- mAsk
traceIfDumpConf "ast"
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True
@ -95,7 +83,8 @@ briDocByExactNoComment
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do
anns <- mAsk
traceIfDumpConf "ast"
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False
@ -110,24 +99,26 @@ briDocByExactInlineOnly
-> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do
anns <- mAsk
traceIfDumpConf "ast"
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let exactPrintNode t = allocateNode $ BDFExternal
let
exactPrintNode t = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey ast)
(foldedAnnKeys ast)
False
t
let errorAction = do
let
errorAction = do
mTell [ErrorUnknownNode infoStr ast]
docLit
$ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
case (fallbackMode, Text.lines exactPrinted) of
(ExactPrintFallbackModeNever, _ ) -> errorAction
(_ , [t]) -> exactPrintNode
(ExactPrintFallbackModeNever, _) -> errorAction
(_, [t]) -> exactPrintNode
(Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
(ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
_ -> errorAction
@ -152,7 +143,8 @@ lrdrNameToTextAnnGen
lrdrNameToTextAnnGen f ast@(L _ n) = do
anns <- mAsk
let t = f $ rdrNameToText n
let hasUni x (ExactPrint.Types.G y, _) = x == y
let
hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the
@ -178,7 +170,8 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
=> Located RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let f x = if x == Text.pack "Data.Type.Equality~"
let
f x = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
lrdrNameToTextAnnGen f ast
@ -199,7 +192,8 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2
let lit = if x == Text.pack "Data.Type.Equality~"
let
lit = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
return $ if hasQuote then Text.cons '\'' lit else lit
@ -223,8 +217,7 @@ extractRestComments ann =
)
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
-- a) connected to any node below (in AST sense) the given node AND
@ -242,7 +235,8 @@ hasCommentsBetween
-> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast
let go1 [] = False
let
go1 [] = False
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 (_ : rest) = go1 rest
go2 [] = False
@ -260,7 +254,8 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected
:: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast
@ -460,12 +455,10 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc =
when cond (addAlternative doc)
addAlternativeCond cond doc = when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative =
CollectAltM . Writer.tell . (: [])
addAlternative = CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) =
@ -482,7 +475,8 @@ docLines l = allocateNode . BDFLines =<< sequence l
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docCols sig l = allocateNode . BDFCols sig =<< sequence l
docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -517,7 +511,8 @@ docAnnotationKW
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
docAnnotationKW annKey kw bdm =
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP
:: AnnKey
@ -631,32 +626,26 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNodePrior ast bdm = do
bd <- bdm
i1 <- allocNodeIndex
return
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd
return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
docWrapNodeRest ast bdm = do
bd <- bdm
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
docWrapNode ast bdms = case bdms of
[] -> []
[bd] -> [docWrapNode ast bd]
(bd1:bdR) | (bdN:bdM) <- reverse bdR ->
(bd1 : bdR) | (bdN : bdM) <- reverse bdR ->
[docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]
_ -> error "cannot happen (TM)"
docWrapNodePrior ast bdms = case bdms of
[] -> []
[bd] -> [docWrapNodePrior ast bd]
(bd1:bdR) -> docWrapNodePrior ast bd1 : bdR
(bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR
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
docWrapNode ast bdsm = do
@ -666,7 +655,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
[bd] -> do
bd' <- docWrapNode ast (return bd)
return [bd']
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> do
(bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do
bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN)
return $ [bd1'] ++ reverse bdM ++ [bdN']
@ -675,16 +664,16 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
bds <- bdsm
case bds of
[] -> return []
(bd1:bdR) -> do
(bd1 : bdR) -> do
bd1' <- docWrapNodePrior ast (return bd1)
return (bd1':bdR)
return (bd1' : bdR)
docWrapNodeRest ast bdsm = do
bds <- bdsm
case reverse bds of
[] -> return []
(bdN:bdR) -> do
(bdN : bdR) -> do
bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse (bdN':bdR)
return $ reverse (bdN' : bdR)
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
docWrapNode ast bdsm = do
@ -778,7 +767,8 @@ briDocMToPPM m = do
briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
briDocMToPPMInner m = do
readers <- MultiRWSS.mGetRawR
let ((x, errs), debugs) =
let
((x, errs), debugs) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)

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

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

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

@ -5,48 +5,38 @@
module Language.Haskell.Brittany.Internal.Layouters.Decl where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data
import qualified Data.Foldable
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Layouters.Type
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import GHC ( GenLocated(L)
, AnnKeywordId(..)
)
import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc )
import GHC (AnnKeywordId(..), GenLocated(L))
import GHC.Data.Bag (bagToList, emptyBag)
import qualified GHC.Data.FastString as FastString
import GHC.Hs
import GHC.Types.Basic ( InlinePragma(..)
, Activation(..)
import qualified GHC.OldList as List
import GHC.Types.Basic
( Activation(..)
, InlinePragma(..)
, InlineSpec(..)
, RuleMatchInfo(..)
, LexicalFixity(..)
, RuleMatchInfo(..)
)
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc)
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.DataDecl
import GHC.Data.Bag ( bagToList, emptyBag )
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
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
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
layoutDecl :: ToBriDoc HsDecl
layoutDecl d@(L loc decl) = case decl of
@ -67,44 +57,53 @@ layoutDecl d@(L loc decl) = case decl of
layoutSig :: ToBriDoc Sig
layoutSig lsig@(L _loc sig) = case sig of
TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ
TypeSig _ names (HsWC _ (HsIB _ typ)) ->
layoutNamesAndType Nothing names typ
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name
specStr <- specStringCompat lsig spec
let phaseStr = case phaseAct of
let
phaseStr = case phaseAct of
NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default
AlwaysActive -> ""
ActiveBefore _ i -> "[~" ++ show i ++ "] "
ActiveAfter _ i -> "[" ++ show i ++ "] "
FinalActive -> error "brittany internal error: FinalActive"
let conlikeStr = case conlike of
let
conlikeStr = case conlike of
FunLike -> ""
ConLike -> "CONLIKE "
docLit
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr
<> Text.pack " #-}"
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ
PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ
ClassOpSig _ False names (HsIB _ typ) ->
layoutNamesAndType Nothing names typ
PatSynSig _ names (HsIB _ typ) ->
layoutNamesAndType (Just "pattern") names typ
_ -> briDocByExactNoComment lsig -- TODO
where
layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do
let keyDoc = case mKeyword of
let
keyDoc = case mKeyword of
Just key -> [appSep . docLit $ Text.pack key]
Nothing -> []
nameStrs <- names `forM` lrdrNameToTextAnn
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ
hasComments <- hasAnyCommentsBelow lsig
shouldBeHanging <- mAsk
<&> _conf_layout
.> _lconfig_hangingTypeSignature
.> confUnpack
shouldBeHanging <-
mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack
if shouldBeHanging
then docSeq $
[ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr]
then
docSeq
$ [ appSep
$ docWrapNodeRest lsig
$ docSeq
$ keyDoc
<> [docLit nameStr]
, docSetBaseY $ docLines
[ docCols
ColTyOpPrefix
@ -133,7 +132,8 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BindStmt _ lPat expr -> do
patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt
docCols
ColBindStmt
[ appSep $ colsWrapPat =<< patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
]
@ -145,9 +145,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
--------------------------------------------------------------------------------
layoutBind
:: ToBriDocC
(HsBindLR GhcPs GhcPs)
(Either [BriDocNumbered] BriDocNumbered)
:: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of
FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do
idStr <- lrdrNameToTextAnn fId
@ -165,17 +163,15 @@ layoutBind lbind@(L _ bind) = case bind of
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?
binderDoc <- docLit $ Text.pack "="
hasComments <- hasAnyCommentsBelow lbind
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal
Nothing
binderDoc
(Just patDocs)
clauseDocs
mWhereArg
hasComments
PatSynBind _ (PSB _ patID lpat rpat dir) -> do
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID
lpat
dir
rpat
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat
_ -> Right <$> unknownNodeError "" lbind
layoutIPBind :: ToBriDoc IPBind
layoutIPBind lipbind@(L _ bind) = case bind of
@ -185,7 +181,13 @@ layoutIPBind lipbind@(L _ bind) = case bind of
binderDoc <- docLit $ Text.pack "="
exprDoc <- layoutExpr expr
hasComments <- hasAnyCommentsBelow lipbind
layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments
layoutPatternBindFinal
Nothing
binderDoc
(Just ipName)
[([], exprDoc, expr)]
Nothing
hasComments
data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
@ -203,7 +205,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
-- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
HsValBinds _ (ValBinds _ bindlrs sigs) -> do
let unordered =
let
unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
@ -213,8 +216,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
return $ Just $ docs
-- x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"
HsIPBinds _ (IPBinds _ bb) ->
Just <$> mapM layoutIPBind bb
HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb
EmptyLocalBinds{} -> return $ Nothing
-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is
@ -242,16 +244,17 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
_ -> pure Nothing
let mIdStr' = fixPatternBindIdentifier match <$> mIdStr
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
(Just idStr, p1:p2:pr) | isInfix -> if null pr
then
docCols ColPatternsFuncInfix
(Just idStr, p1 : p2 : pr) | isInfix -> if null pr
then docCols
ColPatternsFuncInfix
[ appSep $ docForceSingleline p1
, appSep $ docLit $ idStr
, docForceSingleline p2
]
else
docCols ColPatternsFuncInfix
( [docCols ColPatterns
else docCols
ColPatternsFuncInfix
([ docCols
ColPatterns
[ docParenL
, appSep $ docForceSingleline p1
, appSep $ docLit $ idStr
@ -274,22 +277,22 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
let alignmentToken = if null pats then Nothing else funId
hasComments <- hasAnyCommentsBelow lmatch
layoutPatternBindFinal alignmentToken
layoutPatternBindFinal
alignmentToken
binderDoc
(Just patDoc)
clauseDocs
mWhereArg
hasComments
fixPatternBindIdentifier
:: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier match idStr = go $ m_ctxt match
where
go = \case
(FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr
(FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr
(FunRhs _ _ SrcLazy) -> Text.cons '~' idStr
(FunRhs _ _ SrcStrict) -> Text.cons '!' idStr
(FunRhs _ _ NoSrcStrict) -> idStr
(StmtCtxt ctx1 ) -> goInner ctx1
(StmtCtxt ctx1) -> goInner ctx1
_ -> idStr
-- I have really no idea if this path ever occurs, but better safe than
-- risking another "drop bangpatterns" bugs.
@ -308,22 +311,20 @@ layoutPatternBindFinal
-- ^ AnnKey for the node that contains the AnnWhere position annotation
-> Bool
-> ToBriDocM BriDocNumbered
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do
let patPartInline = case mPatDoc of
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments
= do
let
patPartInline = case mPatDoc of
Nothing -> []
Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
patPartParWrap = case mPatDoc of
Nothing -> id
Just patDoc -> docPar (return patDoc)
whereIndent <- do
shouldSpecial <- mAsk
<&> _conf_layout
.> _lconfig_indentWhereSpecial
.> confUnpack
regularIndentAmount <- mAsk
<&> _conf_layout
.> _lconfig_indentAmount
.> confUnpack
shouldSpecial <-
mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack
regularIndentAmount <-
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
pure $ if shouldSpecial
then BrIndentSpecial (max 1 (regularIndentAmount `div` 2))
else BrIndentRegular
@ -332,8 +333,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
Nothing -> return $ []
Just (annKeyWhere, [w]) -> pure . pure <$> docAlt
[ docEnsureIndent BrIndentRegular
$ docSeq
[ docEnsureIndent BrIndentRegular $ docSeq
[ docLit $ Text.pack "where"
, docSeparator
, docForceSingleline $ return w
@ -361,13 +361,16 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ return
<$> ws
]
let singleLineGuardsDoc guards = appSep $ case guards of
let
singleLineGuardsDoc guards = appSep $ case guards of
[] -> docEmpty
[g] -> docSeq
[appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]
gs -> docSeq
gs ->
docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ (List.intersperse docCommaSep
++ (List.intersperse
docCommaSep
(docForceSingleline . return <$> gs)
)
wherePart = case mWhereDocs of
@ -379,10 +382,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
]
_ -> Nothing
indentPolicy <- mAsk
<&> _conf_layout
.> _lconfig_indentPolicy
.> confUnpack
indentPolicy <-
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
runFilteredAlternative $ do
@ -408,7 +409,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
[ docSeq (patPartInline ++ [guardPart])
, docSeq
[ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return
body
]
]
]
@ -418,7 +420,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ docLines
$ [ docForceSingleline
$ docSeq (patPartInline ++ [guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular $ docForceSingleline $ return body
, docEnsureIndent BrIndentRegular $ docForceSingleline $ return
body
]
++ wherePartMultiLine
-- pattern and exactly one clause in single line, body as par;
@ -430,7 +433,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
[ docSeq (patPartInline ++ [guardPart])
, docSeq
[ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return
body
]
]
]
@ -519,11 +523,11 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ clauseDocs
<&> \(guardDocs, bodyDoc, _) ->
docSeq
$ ( case guardDocs of
$ (case guardDocs of
[] -> []
[g] ->
[ docForceSingleline
$ docSeq [appSep $ docLit $ Text.pack "|", return g]
[ docForceSingleline $ docSeq
[appSep $ docLit $ Text.pack "|", return g]
]
gs ->
[ docForceSingleline
@ -553,11 +557,11 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ map docSetBaseY
$ clauseDocs
>>= \(guardDocs, bodyDoc, _) ->
( case guardDocs of
(case guardDocs of
[] -> []
[g] ->
[ docForceSingleline
$ docSeq [appSep $ docLit $ Text.pack "|", return g]
[ docForceSingleline $ docSeq
[appSep $ docLit $ Text.pack "|", return g]
]
gs ->
[ docForceSingleline
@ -585,15 +589,14 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ map docSetBaseY
$ clauseDocs
>>= \(guardDocs, bodyDoc, _) ->
( case guardDocs of
(case guardDocs of
[] -> []
[g] ->
[docSeq [appSep $ docLit $ Text.pack "|", return g]]
(g1:gr) ->
( docSeq [appSep $ docLit $ Text.pack "|", return g1]
: ( gr
<&> \g ->
docSeq
(g1 : gr) ->
(docSeq [appSep $ docLit $ Text.pack "|", return g1]
: (gr
<&> \g -> docSeq
[appSep $ docLit $ Text.pack ",", return g]
)
)
@ -615,43 +618,50 @@ layoutPatSynBind
-> LPat GhcPs
-> ToBriDocM BriDocNumbered
layoutPatSynBind name patSynDetails patDir rpat = do
let patDoc = docLit $ Text.pack "pattern"
let
patDoc = docLit $ Text.pack "pattern"
binderDoc = case patDir of
ImplicitBidirectional -> docLit $ Text.pack "="
_ -> docLit $ Text.pack "<-"
body = colsWrapPat =<< layoutPat rpat
whereDoc = docLit $ Text.pack "where"
mWhereDocs <- layoutPatSynWhere patDir
headDoc <- fmap pure $ docSeq $
[ patDoc
headDoc <-
fmap pure
$ docSeq
$ [ patDoc
, docSeparator
, layoutLPatSyn name patSynDetails
, docSeparator
, binderDoc
]
runFilteredAlternative $ do
addAlternative $
addAlternative
$
-- pattern .. where
-- ..
-- ..
docAddBaseY BrIndentRegular $ docSeq
( [headDoc, docSeparator, body]
++ case mWhereDocs of
docAddBaseY BrIndentRegular
$ docSeq
([headDoc, docSeparator, body] ++ case mWhereDocs of
Just ds -> [docSeparator, docPar whereDoc (docLines ds)]
Nothing -> []
)
addAlternative $
addAlternative
$
-- pattern .. =
-- ..
-- pattern .. <-
-- .. where
-- ..
-- ..
docAddBaseY BrIndentRegular $ docPar
docAddBaseY BrIndentRegular
$ docPar
headDoc
(case mWhereDocs of
Nothing -> body
Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds)
Just ds ->
docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds)
)
-- | Helper method for the left hand side of a pattern synonym
@ -671,18 +681,21 @@ layoutLPatSyn name (InfixCon left right) = do
layoutLPatSyn name (RecCon recArgs) = do
docName <- lrdrNameToTextAnn name
args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs
docSeq . fmap docLit
$ [docName, Text.pack " { " ]
docSeq
. fmap docLit
$ [docName, Text.pack " { "]
<> intersperse (Text.pack ", ") args
<> [Text.pack " }"]
-- | Helper method to get the where clause from of explicitly bidirectional
-- pattern synonyms
layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])
layoutPatSynWhere
:: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])
layoutPatSynWhere hs = case hs of
ExplicitBidirectional (MG _ (L _ lbinds) _) -> do
binderDoc <- docLit $ Text.pack "="
Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds
Just
<$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds
_ -> pure Nothing
--------------------------------------------------------------------------------
@ -692,7 +705,8 @@ layoutPatSynWhere hs = case hs of
layoutTyCl :: ToBriDoc TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of
SynDecl _ name vars fixity typ -> do
let isInfix = case fixity of
let
isInfix = case fixity of
Prefix -> False
Infix -> True
-- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP
@ -723,9 +737,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
-- This isn't quite right, but does give syntactically valid results
let needsParens = not (null rest) || hasOwnParens
docSeq
$ [ docLit $ Text.pack "type"
, docSeparator
]
$ [docLit $ Text.pack "type", docSeparator]
++ [ docParenL | needsParens ]
++ [ layoutTyVarBndr False a
, docSeparator
@ -752,7 +764,7 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
docWrapNodePrior lbndr $ case bndr of
UserTyVar _ _ name -> do
nameStr <- lrdrNameToTextAnn name
docSeq $ [docSeparator | needsSep] ++ [docLit nameStr]
docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr]
KindedTyVar _ _ name kind -> do
nameStr <- lrdrNameToTextAnn name
docSeq
@ -795,7 +807,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
makeForallDoc bndrs = do
bndrDocs <- layoutTyVarBndrs bndrs
docSeq
( [docLit (Text.pack "forall")]
([docLit (Text.pack "forall")]
++ processTyVarBndrsSingleline bndrDocs
)
lhs =
@ -807,14 +819,16 @@ layoutTyFamInstDecl inClass outerNode tfid = do
++ [appSep $ docWrapNode name $ docLit nameStr]
++ intersperse docSeparator (layoutHsTyPats pats)
++ [ docParenR | needsParens ]
hasComments <- (||)
hasComments <-
(||)
<$> hasAnyRegularCommentsConnected outerNode
<*> hasAnyRegularCommentsRest innerNode
typeDoc <- docSharedWrapper layoutType typ
layoutLhsAndType hasComments lhs "=" typeDoc
layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats
:: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = pats <&> \case
HsValArg tm -> layoutType tm
HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]
@ -864,7 +878,11 @@ layoutClsInst lcid@(L _ cid) = docLines
docSortedLines
:: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
docSortedLines l =
allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l
allocateNode
. BDFLines
. fmap unLoc
. List.sortOn (ExactPrint.rs . getLoc)
=<< sequence l
layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig
@ -945,7 +963,8 @@ layoutClsInst lcid@(L _ cid) = docLines
where
go [] = []
go (line1 : lineR) = case Text.stripStart line1 of
st | isTypeOrData st -> st : lineR
st
| isTypeOrData st -> st : lineR
| otherwise -> st : go lineR
isTypeOrData t' =
(Text.pack "type" `Text.isPrefixOf` t')
@ -969,7 +988,12 @@ layoutLhsAndType hasComments lhs sep typeDoc = do
-- lhs = type
-- lhs :: type
addAlternativeCond (not hasComments) $ docSeq
[lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc]
[ lhs
, docSeparator
, docLitS sep
, docSeparator
, docForceSingleline typeDoc
]
-- lhs
-- :: typeA
-- -> typeB

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

File diff suppressed because it is too large Load Diff

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

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

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

@ -4,27 +4,23 @@
module Language.Haskell.Brittany.Internal.Layouters.IE where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.List.Extra
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( unLoc
import GHC
( AnnKeywordId(..)
, GenLocated(L)
, moduleNameString
, AnnKeywordId(..)
, Located
, ModuleName
, moduleNameString
, unLoc
)
import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> Located name
prepareName = ieLWrappedName
@ -37,7 +33,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x _ ns _ -> do
hasComments <- orM
( hasCommentsBetween lie AnnOpenP AnnCloseP
(hasCommentsBetween lie AnnOpenP AnnCloseP
: hasAnyCommentsBelow x
: map hasAnyCommentsBelow ns
)
@ -51,22 +47,27 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
addAlternative
$ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular
$ docPar
(layoutWrapped lie x)
(layoutItems (splitFirstLast sortedNs))
$ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
where
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR]
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]
, docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR]
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
, docParenR
]
layoutItems (FirstLast n1 nMs nN) =
docSetBaseY
$ docLines
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs
++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR]
++ [ docSeq
[docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module"
, docSeparator
@ -92,16 +93,19 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
:: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
:: SortItemsFlag
-> Located [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie]
let sortedLies =
let
sortedLies =
[ items
| group <- Data.List.Extra.groupOn lieToText
$ List.sortOn lieToText lies
| group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
, items <- mergeGroup group
]
let ieDocs = fmap layoutIE $ case shouldSort of
let
ieDocs = fmap layoutIE $ case shouldSort of
ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies
ieCommaDocs <-
@ -133,15 +137,16 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
L _ IEVar{} -> True
_ -> False
thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
thingFolder l1@(L _ IEVar{} ) _ = l1
thingFolder l1@(L _ IEVar{}) _ = l1
thingFolder l1@(L _ IEThingAll{}) _ = l1
thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 ( L _ IEThingAbs{}) = l1
thingFolder l1 (L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
= L
l
(IEThingWith x
(IEThingWith
x
wn
NoIEWildcard
(consItems1 ++ consItems2)
@ -164,7 +169,8 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- () -- no comments
-- ( -- a comment
-- )
layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies
@ -200,9 +206,9 @@ wrappedNameToText = \case
-- Used for sorting, not for printing the formatter's output source code.
lieToText :: LIE GhcPs -> Text
lieToText = \case
L _ (IEVar _ wn ) -> wrappedNameToText wn
L _ (IEThingAbs _ wn ) -> wrappedNameToText wn
L _ (IEThingAll _ wn ) -> wrappedNameToText wn
L _ (IEVar _ wn) -> wrappedNameToText wn
L _ (IEThingAbs _ wn) -> wrappedNameToText wn
L _ (IEThingAll _ wn) -> wrappedNameToText wn
L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some
@ -213,4 +219,5 @@ lieToText = \case
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where
moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)
moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)

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

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

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

@ -3,29 +3,22 @@
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.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)
import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Config.Types
import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..))
import GHC.Hs
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types
( DeltaPos(..)
, deltaRow
, commentContents
)
(DeltaPos(..), commentContents, deltaRow)
layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of
@ -41,22 +34,19 @@ layoutModule lmod@(L _ mod') = case mod' of
-- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports
let tn = Text.pack $ moduleNameString $ unLoc n
allowSingleLineExportList <- mAsk
<&> _conf_layout
.> _lconfig_allowSingleLineExportList
.> confUnpack
allowSingleLineExportList <-
mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
-- the config should not prevent single-line layout when there is no
-- export list
let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
let
allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
docLines
$ docSeq
[ docNodeAnnKW lmod Nothing docEmpty
-- A pseudo node that serves merely to force documentation
-- before the node
, docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do
addAlternativeCond allowSingleLine $
docForceSingleline
$ docSeq
addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq
[ appSep $ docLit $ Text.pack "module"
, appSep $ docLit tn
, docWrapNode lmod $ appSep $ case les of
@ -65,13 +55,11 @@ layoutModule lmod@(L _ mod') = case mod' of
, docSeparator
, docLit $ Text.pack "where"
]
addAlternative
$ docLines
addAlternative $ docLines
[ docAddBaseY BrIndentRegular $ docPar
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn]
)
(docSeq [
docWrapNode lmod $ case les of
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn])
(docSeq
[ docWrapNode lmod $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs False KeepItemsUnsorted x
, docSeparator
@ -102,7 +90,8 @@ data ImportStatementRecord = ImportStatementRecord
}
instance Show ImportStatementRecord where
show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
show r =
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
transformToCommentedImport
@ -121,7 +110,8 @@ transformToCommentedImport is = do
accumF accConnectedComm (annMay, decl) = case annMay of
Nothing ->
( []
, [ ImportStatement ImportStatementRecord { commentsBefore = []
, [ ImportStatement ImportStatementRecord
{ commentsBefore = []
, commentsAfter = []
, importStatement = decl
}
@ -200,10 +190,8 @@ commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
commentedImportsToDoc = \case
EmptyLine -> docLitS ""
IndependentComment c -> commentToDoc c
ImportStatement r ->
docSeq
( layoutImport (importStatement r)
: map commentToDoc (commentsAfter r)
)
ImportStatement r -> docSeq
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
where
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)
commentToDoc (c, DP (_y, x)) =
docLitS (replicate x ' ' ++ commentContents c)

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

@ -3,28 +3,19 @@
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.Sequence as Seq
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( GenLocated(L)
, ol_val
)
import GHC (GenLocated(L), ol_val)
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.LayouterBasics
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
-- | layouts patterns (inside function bindings, case alternatives, let
-- bindings or do notation). E.g. for input
@ -40,11 +31,9 @@ layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr
VarPat _ n ->
fmap Seq.singleton $ docLit $ lrdrNameToText n
VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr
LitPat _ lit ->
fmap Seq.singleton $ allocateNode $ litBriDoc lit
LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr
ParPat _ inner -> do
-- (nestedpat) -> expr
@ -74,10 +63,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
then return <$> docLit nameDoc
else do
x1 <- appSep (docLit nameDoc)
xR <- fmap Seq.fromList
$ sequence
$ spacifyDocs
$ fmap colsWrapPat argDocs
xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap
colsWrapPat
argDocs
return $ x1 Seq.<| xR
ConPat _ lname (InfixCon left right) -> do
-- a :< b -> expr
@ -90,7 +78,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- Abc{} -> expr
let t = lrdrNameToText lname
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, b, c } -> expr2
let t = lrdrNameToText lname
@ -103,8 +91,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
Seq.singleton <$> docSeq
[ appSep $ docLit t
, appSep $ docLit $ Text.pack "{"
, docSeq $ List.intersperse docCommaSep
$ fds <&> \case
, docSeq $ List.intersperse docCommaSep $ fds <&> \case
(fieldName, Just fieldDoc) -> docSeq
[ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "="
@ -117,11 +104,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
-- Abc { .. } -> expr
let t = lrdrNameToText lname
Seq.singleton <$> docSeq
[ appSep $ docLit t
, docLit $ Text.pack "{..}"
]
ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do
Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"]
ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti))))
| dotdoti == length fs -> do
-- Abc { a = locA, .. }
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
@ -184,7 +169,8 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do
-- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val
ol
negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc]
@ -196,9 +182,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend
:: LPat GhcPs
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
:: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do
patDocs <- layoutPat pat
case Seq.viewl patDocs of
@ -220,8 +204,5 @@ wrapPatListy elems both start end = do
x1 Seq.:< rest -> do
sDoc <- start
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

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

@ -4,26 +4,19 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
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 (GenLocated(L))
import GHC.Hs
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.Decl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do
@ -68,7 +61,8 @@ layoutStmt lstmt@(L _ stmt) = do
f = case indentPolicy of
IndentPolicyFree -> docSetBaseAndIndent
IndentPolicyLeft -> docForceSingleline
IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent
IndentPolicyMultiple
| indentFourPlus -> docSetBaseAndIndent
| otherwise -> docForceSingleline
in f $ return bindDoc
]
@ -84,7 +78,8 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc
addAlternativeCond (isFree || indentFourPlus) $ docSeq
[ appSep $ docLit $ Text.pack "let"
, let f = if indentFourPlus
, let
f = if indentFourPlus
then docEnsureIndent BrIndentRegular
else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs
@ -95,7 +90,8 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc
addAlternativeCond (not indentFourPlus)
$ docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "let")
$ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1

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

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

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

@ -3,28 +3,18 @@
module Language.Haskell.Brittany.Internal.Layouters.Type where
import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L))
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import GHC.Utils.Outputable (ftext, showSDocUnsafe)
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Text as Text
import qualified GHC.OldList as List
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
(FirstLastView(..), splitFirstLast)
layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
@ -32,43 +22,33 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of
IsPromoted -> docSeq
[ docSeparator
, docTick
, docWrapNode name $ docLit t
]
IsPromoted ->
docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
NotPromoted -> docWrapNode name $ docLit t
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let maybeForceML = case typ2 of
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt
[ let
open = docLit $ Text.pack "forall"
in docSeq ([open]++tyVarDocLineList)
[ let open = docLit $ Text.pack "forall"
in docSeq ([open] ++ tyVarDocLineList)
, docPar
(docLit (Text.pack "forall"))
(docLines
$ tyVarDocs <&> \case
(docLines $ tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular
$ docLines
[ docCols ColTyOpPrefix
[ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname]
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit $ Text.pack ")"
])
]
)
]
contextDoc = case cntxtDocs of
[] -> docLit $ Text.pack "()"
@ -77,20 +57,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ let
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep
$ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close])
list =
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close])
, let
open = docCols ColTyOpPrefix
open = docCols
ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc ->
docCols ColTyOpPrefix
[ docCommaSep
, docAddBaseY (BrIndentSpecial 2) cntxtDoc
]
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
in docPar open $ docLines $ list ++ [close]
]
docAlt
@ -98,10 +77,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ docSeq
[ if null bndrs
then docEmpty
else let
else
let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open, docSeparator]++tyVarDocLineList++[close])
in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])
, docForceSingleline contextDoc
, docLit $ Text.pack " => "
, docForceSingleline typeDoc
@ -112,13 +92,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- -> c
, docPar
forallDoc
( docLines
[ docCols ColTyOpPrefix
(docLines
[ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3)
$ contextDoc
, docAddBaseY (BrIndentSpecial 3) $ contextDoc
]
, docCols ColTyOpPrefix
, docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
@ -129,7 +110,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
let bndrs = getBinders hsf
typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs
let maybeForceML = case typ2 of
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
@ -138,17 +120,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ docSeq
[ if null bndrs
then docEmpty
else let
else
let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open]++tyVarDocLineList++[close])
in docSeq ([open] ++ tyVarDocLineList ++ [close])
, docForceSingleline $ return $ typeDoc
]
-- :: forall x
-- . x
, docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
( docCols ColTyOpPrefix
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
@ -160,21 +144,16 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
(docLit (Text.pack "forall"))
(docLines
$ (tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular
$ docLines
[ docCols ColTyOpPrefix
[ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
(tname, Nothing) ->
docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname]
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit $ Text.pack ")"
]
)
++[ docCols ColTyOpPrefix
++ [ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
@ -192,25 +171,23 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ let
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep
$ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close])
list =
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close])
, let
open = docCols ColTyOpPrefix
open = docCols
ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2)
$ head cntxtDocs
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc ->
docCols ColTyOpPrefix
[ docCommaSep
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]
in docPar open $ docLines $ list ++ [close]
]
let maybeForceML = case typ1 of
let
maybeForceML = case typ1 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
docAlt
@ -225,7 +202,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- -> c
, docPar
(docForceSingleline contextDoc)
( docCols ColTyOpPrefix
(docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
]
@ -234,24 +212,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsFunTy _ _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
let maybeForceML = case typ2 of
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
hasComments <- hasAnyCommentsBelow ltype
docAlt $
[ docSeq
docAlt
$ [ docSeq
[ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2
]
| not hasComments
] ++
[ docPar
]
++ [ docPar
(docNodeAnnKW ltype Nothing typeDoc1)
( docCols ColTyOpPrefix
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3)
$ maybeForceML typeDoc2
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2
]
)
]
@ -264,24 +243,28 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack ")"
]
, docPar
( docCols ColTyOpPrefix
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
])
]
)
(docLit $ Text.pack ")")
]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
let
gather
:: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1
docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead : (docRest >>= \d ->
[ docSeparator, docForceSingleline d ])
$ docForceSingleline docHead
: (docRest >>= \d -> [docSeparator, docForceSingleline d])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
HsAppTy _ typ1 typ2 -> do
@ -293,9 +276,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docSeparator
, docForceSingleline typeDoc2
]
, docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
]
HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
@ -306,10 +287,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "]"
]
, docPar
( docCols ColTyOpPrefix
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
])
]
)
(docLit $ Text.pack "]")
]
HsTupleTy _ tupleSort typs -> case tupleSort of
@ -318,38 +301,46 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple
where
unboxed = if null typs then error "brittany internal error: unboxed unit"
unboxed = if null typs
then error "brittany internal error: unboxed unit"
else unboxedL
simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()"
simpleL = do
docs <- docSharedWrapper layoutType `mapM` typs
let end = docLit $ Text.pack ")"
lines = List.tail docs <&> \d ->
docAddBaseY (BrIndentSpecial 2)
let
end = docLit $ Text.pack ")"
lines =
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt
[ docSeq $ [docLit $ Text.pack "("]
[ docSeq
$ [docLit $ Text.pack "("]
++ docWrapNodeRest ltype commaDocs
++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in docPar
in
docPar
(docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end])
]
unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs
let start = docParenHashLSep
let
start = docParenHashLSep
end = docParenHashRSep
docAlt
[ docSeq $ [start]
[ docSeq
$ [start]
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end]
, let
line1 = docCols ColTyOpPrefix [start, head docs]
lines = List.tail docs <&> \d ->
docAddBaseY (BrIndentSpecial 2)
lines =
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
in docPar
(docAddBaseY (BrIndentSpecial 2) line1)
@ -419,20 +410,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype
$ docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
[ docWrapNodeRest ltype $ docLit $ Text.pack
("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1
]
, docPar
( docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
)
(docCols ColTyOpPrefix
[ docWrapNodeRest ltype
$ docLit $ Text.pack ":: "
(docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
])
]
)
]
-- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do
@ -473,7 +462,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
else docPar
typeDoc1
( docCols
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1
@ -571,15 +560,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
addAlternativeCond (not hasComments)
$ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))
++ List.intersperse
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
++ [docLit $ Text.pack " ]"]
addAlternative $
let
start = docCols ColList
[appSep $ docLit $ Text.pack "'[", e1]
linesM = ems <&> \d ->
docCols ColList [specialCommaSep, d]
lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
addAlternative
$ let
start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
lineN = docCols
ColList
[specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
]
@ -592,8 +585,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ ->
docLit $ Text.pack "_"
HsWildCardTy _ -> docLit $ Text.pack "_"
HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do
@ -611,9 +603,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "@"
, docForceSingleline k
]
, docPar
t
(docSeq [docLit $ Text.pack "@", k ])
, docPar t (docSeq [docLit $ Text.pack "@", k])
]
layoutTyVarBndrs

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

@ -2,26 +2,22 @@
module Language.Haskell.Brittany.Internal.Obfuscation where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Data.Char
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Data.Char
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import System.Random
obfuscate :: Text -> IO Text
obfuscate input = do
let predi x = isAlphaNum x || x `elem` "_'"
let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input)
let idents = Set.toList $ Set.fromList $ filter (all predi) groups
let exceptionFilter x | x `elem` keywords = False
let
exceptionFilter x | x `elem` keywords = False
exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x = not $ null $ drop 1 x
let filtered = filter exceptionFilter idents

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

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

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

@ -1,21 +1,15 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.Brittany.Internal.PreludeUtils where
import Prelude
import Control.Applicative
import Control.DeepSeq (NFData, force)
import Control.Exception.Base (evaluate)
import Control.Monad
import qualified Data.Strict.Maybe as Strict
import Debug.Trace
import Control.Monad
import Prelude
import System.IO
import Control.DeepSeq ( NFData, force )
import Control.Exception.Base ( evaluate )
import Control.Applicative
instance Applicative Strict.Maybe where
pure = Strict.Just
Strict.Just f <*> Strict.Just x = Strict.Just (f x)
@ -30,12 +24,12 @@ instance Alternative Strict.Maybe where
x <|> Strict.Nothing = x
_ <|> x = x
traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
traceFunctionWith
:: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
traceFunctionWith name s1 s2 f x = trace traceStr y
where
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
(<&!>) = flip (<$!>)

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

@ -9,25 +9,18 @@
module Language.Haskell.Brittany.Internal.Transformations.Alt where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Memo as Memo
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.HList.ContainsType
import qualified Data.List.Extra
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Data.HList.ContainsType
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import qualified Control.Monad.Memo as Memo
import Language.Haskell.Brittany.Internal.Utils
data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line
@ -35,7 +28,7 @@ data AltCurPos = AltCurPos
, _acp_indentPrep :: Int -- indentChange affecting the next Par
, _acp_forceMLFlag :: AltLineModeState
}
deriving (Show)
deriving Show
data AltLineModeState
= AltLineModeStateNone
@ -49,12 +42,14 @@ altLineModeRefresh :: AltLineModeState -> AltLineModeState
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction
altLineModeRefresh AltLineModeStateContradiction =
AltLineModeStateContradiction
altLineModeDecay :: AltLineModeState -> AltLineModeState
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True
altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) =
AltLineModeStateForceML True
altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
@ -119,7 +114,13 @@ transformAlts =
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered
rec
:: BriDocNumbered
-> Memo.MemoT
Int
[VerticalSpacing]
(MultiRWSS.MultiRWS r w (AltCurPos ': s))
BriDocNumbered
rec bdX@(brDcId, brDc) = do
let reWrap = (,) brDcId
-- debugAcp :: AltCurPos <- mGet
@ -130,10 +131,8 @@ transformAlts =
-- BDWrapAnnKey annKey <$> rec bd
BDFEmpty{} -> processSpacingSimple bdX $> bdX
BDFLit{} -> processSpacingSimple bdX $> bdX
BDFSeq list ->
reWrap . BDFSeq <$> list `forM` rec
BDFCols sig list ->
reWrap . BDFCols sig <$> list `forM` rec
BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec
BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec
BDFSeparator -> processSpacingSimple bdX $> bdX
BDFAddBaseY indent bd -> do
acp <- mGet
@ -162,22 +161,18 @@ transformAlts =
BDFIndentLevelPop bd -> do
reWrap . BDFIndentLevelPop <$> rec bd
BDFPar indent sameLine indented -> do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAdd = case indent of
indAmount <-
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let
indAdd = case indent of
BrIndentNone -> 0
BrIndentRegular -> indAmount
BrIndentSpecial i -> i
acp <- mGet
let ind = _acp_indent acp + _acp_indentPrep acp + indAdd
mSet $ acp
{ _acp_indent = ind
, _acp_indentPrep = 0
}
mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 }
sameLine' <- rec sameLine
mModify $ \acp' -> acp'
{ _acp_line = ind
, _acp_indent = ind
}
mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind }
indented' <- rec indented
return $ reWrap $ BDFPar indent sameLine' indented'
BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a
@ -185,14 +180,16 @@ transformAlts =
-- fail-early approach; BDEmpty does not
-- make sense semantically for Alt[].
BDFAlt alts -> do
altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
altChooser <-
mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
case altChooser of
AltChooserSimpleQuick -> do
rec $ head alts
AltChooserShallowBest -> do
spacings <- alts `forM` getSpacing
acp <- mGet
let lineCheck LineModeInvalid = False
let
lineCheck LineModeInvalid = False
lineCheck (LineModeValid (VerticalSpacing _ p _)) =
case _acp_forceMLFlag acp of
AltLineModeStateNone -> True
@ -202,36 +199,42 @@ transformAlts =
-- TODO: use COMPLETE pragma instead?
lineCheck _ = error "ghc exhaustive check is insufficient"
lconf <- _conf_layout <$> mAsk
let options = -- trace ("considering options:" ++ show (length alts, acp)) $
let
options = -- trace ("considering options:" ++ show (length alts, acp)) $
(zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( hasSpace1 lconf acp vs && lineCheck vs, bd))
(hasSpace1 lconf acp vs && lineCheck vs, bd)
)
rec
$ fromMaybe (-- trace ("choosing last") $
List.last alts)
$ Data.List.Extra.firstJust (\(_i::Int, (b,x)) ->
$ Data.List.Extra.firstJust
(\(_i :: Int, (b, x)) ->
[ -- traceShow ("choosing option " ++ show i) $
x
| b
])
$ zip [1..] options
]
)
$ zip [1 ..] options
AltChooserBoundedSearch limit -> do
spacings <- alts `forM` getSpacings limit
acp <- mGet
let lineCheck (VerticalSpacing _ p _) =
case _acp_forceMLFlag acp of
let
lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of
AltLineModeStateNone -> True
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False
lconf <- _conf_layout <$> mAsk
let options = -- trace ("considering options:" ++ show (length alts, acp)) $
let
options = -- trace ("considering options:" ++ show (length alts, acp)) $
(zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( any (hasSpace2 lconf acp) vs
&& any lineCheck vs, bd))
let checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])
(any (hasSpace2 lconf acp) vs && any lineCheck vs, bd)
)
let
checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ])
rec
$ fromMaybe (-- trace ("choosing last") $
List.last alts)
@ -255,7 +258,9 @@ transformAlts =
BDFForwardLineMode bd -> do
acp <- mGet
x <- do
mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp }
mSet $ acp
{ _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp
}
rec bd
acp' <- mGet
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
@ -264,7 +269,9 @@ transformAlts =
BDFPlain{} -> processSpacingSimple bdX $> bdX
BDFAnnotationPrior annKey bd -> do
acp <- mGet
mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
mSet $ acp
{ _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp
}
bd' <- rec bd
return $ reWrap $ BDFAnnotationPrior annKey bd'
BDFAnnotationRest annKey bd ->
@ -274,16 +281,13 @@ transformAlts =
BDFMoveToKWDP annKey kw b bd ->
reWrap . BDFMoveToKWDP annKey kw b <$> rec bd
BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.
BDFLines (l:lr) -> do
BDFLines (l : lr) -> do
ind <- _acp_indent <$> mGet
l' <- rec l
lr' <- lr `forM` \x -> do
mModify $ \acp -> acp
{ _acp_line = ind
, _acp_indent = ind
}
mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind }
rec x
return $ reWrap $ BDFLines (l':lr')
return $ reWrap $ BDFLines (l' : lr')
BDFEnsureIndent indent bd -> do
acp <- mGet
indAdd <- fixIndentationForMultiple acp indent
@ -302,14 +306,21 @@ transformAlts =
mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of
BrIndentNone -> r
BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r
BrIndentRegular ->
reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r
BDFNonBottomSpacing _ bd -> rec bd
BDFSetParSpacing bd -> rec bd
BDFForceParSpacing bd -> rec bd
BDFDebug s bd -> do
acp :: AltCurPos <- mGet
tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp
tellDebugMess
$ "transformAlts: BDFDEBUG "
++ s
++ " (node-id="
++ show brDcId
++ "): acp="
++ show acp
reWrap . BDFDebug s <$> rec bd
processSpacingSimple
:: ( MonadMultiReader Config m
@ -325,7 +336,8 @@ transformAlts =
mSet $ acp { _acp_line = _acp_line acp + i }
LineModeValid VerticalSpacing{} -> error "processSpacingSimple par"
_ -> error "ghc exhaustive check is insufficient"
hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool
hasSpace1
:: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool
hasSpace1 _ _ LineModeInvalid = False
hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs
hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"
@ -333,8 +345,13 @@ transformAlts =
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _)
= line + sameLine <= confUnpack (_lconfig_cols lconf)
hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)
= line + sameLine <= confUnpack (_lconfig_cols lconf)
&& indent + indentPrep + par <= confUnpack (_lconfig_cols lconf)
= line
+ sameLine
<= confUnpack (_lconfig_cols lconf)
&& indent
+ indentPrep
+ par
<= confUnpack (_lconfig_cols lconf)
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
= line + sameLine <= confUnpack (_lconfig_cols lconf)
@ -353,10 +370,11 @@ getSpacing !bridoc = rec bridoc
-- BDWrapAnnKey _annKey bd -> rec bd
BDFEmpty ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
BDFLit t ->
return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False
BDFSeq list ->
sumVs <$> rec `mapM` list
BDFLit t -> return $ LineModeValid $ VerticalSpacing
(Text.length t)
VerticalSpacingParNone
False
BDFSeq list -> sumVs <$> rec `mapM` list
BDFCols _sig list -> sumVs <$> rec `mapM` list
BDFSeparator ->
return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False
@ -365,17 +383,23 @@ getSpacing !bridoc = rec bridoc
return $ mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of
VerticalSpacingParAlways i ->
VerticalSpacingParAlways $ case indent of
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
VerticalSpacingParSome i ->
VerticalSpacingParSome $ case indent of
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
@ -390,11 +414,13 @@ getSpacing !bridoc = rec bridoc
-- the reason is that we really want to _keep_ it Just if it is
-- just so we properly communicate the is-multiline fact.
-- An alternative would be setting to (Just 0).
{ _vs_sameLine = max (_vs_sameLine vs)
{ _vs_sameLine = max
(_vs_sameLine vs)
(case _vs_paragraph vs of
VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i)
VerticalSpacingParAlways i -> min colMax i
)
, _vs_paragraph = VerticalSpacingParSome 0
}
BDFBaseYPop bd -> rec bd
@ -408,17 +434,24 @@ getSpacing !bridoc = rec bridoc
| VerticalSpacing lsp mPsp _ <- mVs
, indSp <- mIndSp
, lineMax <- getMaxVS $ mIndSp
, let pspResult = case mPsp of
VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax
, let
pspResult = case mPsp of
VerticalSpacingParSome psp ->
VerticalSpacingParSome $ max psp lineMax
VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax
VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax
, let parFlagResult = mPsp == VerticalSpacingParNone
&& _vs_paragraph indSp == VerticalSpacingParNone
VerticalSpacingParAlways psp ->
VerticalSpacingParAlways $ max psp lineMax
, let
parFlagResult =
mPsp
== VerticalSpacingParNone
&& _vs_paragraph indSp
== VerticalSpacingParNone
&& _vs_parFlag indSp
]
BDFPar{} -> error "BDPar with indent in getSpacing"
BDFAlt [] -> error "empty BDAlt"
BDFAlt (alt:_) -> rec alt
BDFAlt (alt : _) -> rec alt
BDFForceMultiline bd -> do
mVs <- rec bd
return $ mVs >>= _vs_paragraph .> \case
@ -440,35 +473,33 @@ getSpacing !bridoc = rec bridoc
BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFLines [] -> return
$ LineModeValid
$ VerticalSpacing 0 VerticalSpacingParNone False
BDFLines ls@(_:_) -> do
BDFLines [] ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
BDFLines ls@(_ : _) -> do
lSps <- rec `mapM` ls
let (mVs:_) = lSps -- separated into let to avoid MonadFail
return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
let (mVs : _) = lSps -- separated into let to avoid MonadFail
return
$ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
| VerticalSpacing lsp _ _ <- mVs
, lineMax <- getMaxVS $ maxVs $ lSps
]
BDFEnsureIndent indent bd -> do
mVs <- rec bd
let addInd = case indent of
let
addInd = case indent of
BrIndentNone -> 0
BrIndentRegular -> confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
BrIndentRegular ->
confUnpack $ _lconfig_indentAmount $ _conf_layout $ config
BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp pf) ->
VerticalSpacing (lsp + addInd) psp pf
BDFNonBottomSpacing b bd -> do
mVs <- rec bd
return
$ mVs
<|> LineModeValid
return $ mVs <|> LineModeValid
(VerticalSpacing
0
(if b then VerticalSpacingParSome 0
(if b
then VerticalSpacingParSome 0
else VerticalSpacingParAlways colMax
)
False
@ -478,16 +509,29 @@ getSpacing !bridoc = rec bridoc
return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDFForceParSpacing bd -> do
mVs <- rec bd
return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]
return
$ [ vs
| vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
]
BDFDebug s bd -> do
r <- rec bd
tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r
tellDebugMess
$ "getSpacing: BDFDebug "
++ show s
++ " (node-id="
++ show brDcId
++ "): mVs="
++ show r
return r
return result
maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
maxVs
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
maxVs = foldl'
(liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->
VerticalSpacing (max x1 y1) (case (x2, y2) of
(liftM2
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing
(max x1 y1)
(case (x2, y2) of
(x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
@ -497,9 +541,14 @@ getSpacing !bridoc = rec bridoc
(VerticalSpacingParSome j, VerticalSpacingParAlways i) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y) False))
VerticalSpacingParSome $ max x y
)
False
)
)
(LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)
sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
sumVs
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
sumVs sps = foldl' (liftM2 go) initial sps
where
go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing
@ -508,13 +557,14 @@ getSpacing !bridoc = rec bridoc
(x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
VerticalSpacingParAlways $ i + j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ i+j
VerticalSpacingParAlways $ i + j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
VerticalSpacingParAlways $ i + j
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ x + y)
VerticalSpacingParSome $ x + y
)
x3
singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone
singleline _ = False
@ -546,20 +596,23 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- process could lead to exponential runtime behaviour.
-- TODO: 3 is arbitrary.
preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]
preFilterLimit = take (3*limit)
preFilterLimit = take (3 * limit)
memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v
memoWithKey k v = Memo.memo (const v) k
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
rec
:: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
rec (brDcId, brdc) = memoWithKey brDcId $ do
config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack
let hasOkColCount (VerticalSpacing lsp psp _) =
let
hasOkColCount (VerticalSpacing lsp psp _) =
lsp <= colMax && case psp of
VerticalSpacingParNone -> True
VerticalSpacingParSome i -> i <= colMax
VerticalSpacingParAlways{} -> True
let specialCompare vs1 vs2 =
if ( (_vs_sameLine vs1 == _vs_sameLine vs2)
let
specialCompare vs1 vs2 =
if ((_vs_sameLine vs1 == _vs_sameLine vs2)
&& (_vs_parFlag vs1 == _vs_parFlag vs2)
)
then case (_vs_paragraph vs1, _vs_paragraph vs2) of
@ -567,11 +620,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
if i1 < i2 then Smaller else Bigger
(p1, p2) -> if p1 == p2 then Smaller else Unequal
else Unequal
let allowHangingQuasiQuotes =
config
& _conf_layout
& _lconfig_allowHangingQuasiQuotes
& confUnpack
let
allowHangingQuasiQuotes =
config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack
let -- this is like List.nub, with one difference: if two elements
-- are unequal only in _vs_paragraph, with both ParAlways, we
-- treat them like equals and replace the first occurence with the
@ -591,7 +642,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- applied whenever in a parent the combination of spacings from
-- its children might cause excess of the upper bound.
filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing]
filterAndLimit = take limit
filterAndLimit =
take limit
-- prune so we always consider a constant
-- amount of spacings per node of the BriDoc.
. specialNub
@ -623,12 +675,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
. preFilterLimit
result <- case brdc of
-- BDWrapAnnKey _annKey bd -> rec bd
BDFEmpty ->
return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLit t ->
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFSeq list ->
fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
return
$ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFCols _sig list ->
fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFSeparator ->
@ -638,17 +689,23 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of
VerticalSpacingParAlways i ->
VerticalSpacingParAlways $ case indent of
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
VerticalSpacingParSome i ->
VerticalSpacingParSome $ case indent of
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
@ -663,11 +720,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- the reason is that we really want to _keep_ it Just if it is
-- just so we properly communicate the is-multiline fact.
-- An alternative would be setting to (Just 0).
{ _vs_sameLine = max (_vs_sameLine vs)
{ _vs_sameLine = max
(_vs_sameLine vs)
(case _vs_paragraph vs of
VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i)
VerticalSpacingParAlways i -> min colMax i
)
, _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParSome i -> VerticalSpacingParSome i
@ -679,13 +738,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDFPar BrIndentNone sameLine indented -> do
mVss <- filterAndLimit <$> rec sameLine
indSps <- filterAndLimit <$> rec indented
let mVsIndSp = take limit
$ [ (x,y)
| x<-mVss
, y<-indSps
]
return $ mVsIndSp <&>
\(VerticalSpacing lsp mPsp _, indSp) ->
let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ]
return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) ->
VerticalSpacing
lsp
(case mPsp of
@ -693,9 +747,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO
VerticalSpacingParNone -> spMakePar indSp
VerticalSpacingParAlways psp ->
VerticalSpacingParAlways $ max psp $ getMaxVS indSp)
( mPsp == VerticalSpacingParNone
&& _vs_paragraph indSp == VerticalSpacingParNone
VerticalSpacingParAlways $ max psp $ getMaxVS indSp
)
(mPsp
== VerticalSpacingParNone
&& _vs_paragraph indSp
== VerticalSpacingParNone
&& _vs_parFlag indSp
)
@ -707,23 +764,21 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ filterAndLimit =<< r
BDFForceMultiline bd -> do
mVs <- filterAndLimit <$> rec bd
return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs
return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForceSingleline bd -> do
mVs <- filterAndLimit <$> rec bd
return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs
return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForwardLineMode bd -> rec bd
BDFExternal _ _ _ txt | [t] <- Text.lines txt ->
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFExternal{} ->
return $ [] -- yes, we just assume that we cannot properly layout
return
$ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout
-- this.
BDFPlain t -> return
[ case Text.lines t of
[] -> VerticalSpacing 0 VerticalSpacingParNone False
[t1 ] -> VerticalSpacing
(Text.length t1)
VerticalSpacingParNone
False
[t1] ->
VerticalSpacing (Text.length t1) VerticalSpacingParNone False
(t1 : _) -> VerticalSpacing
(Text.length t1)
(VerticalSpacingParAlways 0)
@ -734,22 +789,22 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLines ls@(_:_) -> do
BDFLines [] ->
return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLines ls@(_ : _) -> do
-- we simply assume that lines is only used "properly", i.e. in
-- such a way that the first line can be treated "as a part of the
-- paragraph". That most importantly means that Lines should never
-- be inserted anywhere but at the start of the line. A
-- counterexample would be anything like Seq[Lit "foo", Lines].
lSpss <- map filterAndLimit <$> rec `mapM` ls
let worbled = fmap reverse
$ sequence
$ reverse
$ lSpss
sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1)
(spMakePar $ maxVs lSps)
False
sumF [] = error $ "should not happen. if my logic does not fail"
let
worbled = fmap reverse $ sequence $ reverse $ lSpss
sumF lSps@(lSp1 : _) =
VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False
sumF [] =
error
$ "should not happen. if my logic does not fail"
++ "me, this follows from not (null ls)."
return $ sumF <$> worbled
-- lSpss@(mVs:_) <- rec `mapM` ls
@ -765,12 +820,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps
BDFEnsureIndent indent bd -> do
mVs <- rec bd
let addInd = case indent of
let
addInd = case indent of
BrIndentNone -> 0
BrIndentRegular -> confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
BrIndentRegular ->
confUnpack $ _lconfig_indentAmount $ _conf_layout $ config
BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->
VerticalSpacing (lsp + addInd) psp parFlag
@ -781,9 +835,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- problem but breaks certain other cases.
mVs <- rec bd
return $ if null mVs
then [VerticalSpacing
then
[ VerticalSpacing
0
(if b then VerticalSpacingParSome 0
(if b
then VerticalSpacingParSome 0
else VerticalSpacingParAlways colMax
)
False
@ -832,16 +888,25 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDFForceParSpacing bd -> do
mVs <- preFilterLimit <$> rec bd
return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]
return
$ [ vs
| vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
]
BDFDebug s bd -> do
r <- rec bd
tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r)
tellDebugMess
$ "getSpacings: BDFDebug "
++ show s
++ " (node-id="
++ show brDcId
++ "): vs="
++ show (take 9 r)
return r
return result
maxVs :: [VerticalSpacing] -> VerticalSpacing
maxVs = foldl'
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->
VerticalSpacing
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing
(max x1 y1)
(case (x2, y2) of
(x, VerticalSpacingParNone) -> x
@ -853,8 +918,10 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y)
False)
VerticalSpacingParSome $ max x y
)
False
)
(VerticalSpacing 0 VerticalSpacingParNone False)
sumVs :: [VerticalSpacing] -> VerticalSpacing
sumVs sps = foldl' go initial sps
@ -865,12 +932,14 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
(x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
VerticalSpacingParAlways $ i + j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ i+j
VerticalSpacingParAlways $ i + j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)
VerticalSpacingParAlways $ i + j
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ x + y
)
x3
singleline x = _vs_paragraph x == VerticalSpacingParNone
isPar x = _vs_parFlag x
@ -893,7 +962,8 @@ fixIndentationForMultiple
:: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int
fixIndentationForMultiple acp indent = do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAddRaw = case indent of
let
indAddRaw = case indent of
BrIndentNone -> 0
BrIndentRegular -> indAmount
BrIndentSpecial i -> i
@ -903,7 +973,8 @@ fixIndentationForMultiple acp indent = do
indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
pure $ if indPolicy == IndentPolicyMultiple
then
let indAddMultiple1 =
let
indAddMultiple1 =
indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount)
indAddMultiple2 = if indAddMultiple1 <= 0
then indAddMultiple1 + indAmount

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

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

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

@ -3,24 +3,19 @@
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.PreludeUtils
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
import Language.Haskell.Brittany.Internal.Utils
-- note that this is not total, and cannot be with that exact signature.
mergeIndents :: BrIndent -> BrIndent -> BrIndent
mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) =
BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents"
@ -36,12 +31,12 @@ transformSimplifyFloating = stepBO .> stepFull
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
BDAnnotationPrior annKey1 (BDDebug s x) ->
@ -52,11 +47,20 @@ transformSimplifyFloating = stepBO .> stepFull
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]
Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationRest annKey1 (BDDebug s x) ->
@ -67,49 +71,57 @@ transformSimplifyFloating = stepBO .> stepFull
BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDAnnotationKW annKey1 kw (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
_ -> Nothing
descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_:_)) ->
BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDBaseYPushCur (BDDebug s x) ->
Just $ BDDebug s (BDBaseYPushCur x)
BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x)
_ -> Nothing
descendBYPop = transformDownMay $ \case
BDBaseYPop (BDCols sig cols@(_:_)) ->
BDBaseYPop (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
BDBaseYPop (BDDebug s x) ->
Just $ BDDebug s (BDBaseYPop x)
BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x)
_ -> Nothing
descendILPush = transformDownMay $ \case
BDIndentLevelPushCur (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just
$ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPushCur x)
_ -> Nothing
descendILPop = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols@(_:_)) ->
BDIndentLevelPop (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
BDIndentLevelPop (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPop x)
BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x)
_ -> Nothing
descendAddB = transformDownMay $ \case
BDAddBaseY BrIndentNone x ->
Just x
BDAddBaseY BrIndentNone x -> Just x
-- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
Just
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
-- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented
@ -121,14 +133,11 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} ->
Just $ lit
BDAddBaseY _ lit@BDLit{} -> Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) ->
Just $ BDBaseYPop (BDAddBaseY ind x)
BDAddBaseY ind (BDDebug s x) ->
Just $ BDDebug s (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPop x) ->
Just $ BDIndentLevelPop (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPushCur x) ->
@ -152,34 +161,34 @@ transformSimplifyFloating = stepBO .> stepFull
x -> x
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
Uniplate.rewrite $ \case
BDAddBaseY BrIndentNone x ->
Just $ x
BDAddBaseY BrIndentNone x -> Just $ x
-- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
Just
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
-- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY _ lit@BDLit{} ->
Just $ lit
BDAddBaseY _ lit@BDLit{} -> Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) ->
Just $ BDBaseYPop (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->
Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l):lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr)
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr)
-- EnsureIndent float-in
-- BDEnsureIndent indent (BDCols sig (col:colr)) ->
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
@ -191,9 +200,18 @@ transformSimplifyFloating = stepBO .> stepFull
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]
Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
_ -> Nothing

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

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

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

@ -3,14 +3,9 @@
module Language.Haskell.Brittany.Internal.Transformations.Par where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
transformSimplifyPar :: BriDoc -> BriDoc
transformSimplifyPar = transformUp $ \case
@ -24,12 +19,15 @@ transformSimplifyPar = transformUp $ \case
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 ->
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines | any ( \case
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines -> case go lines of
lines
-> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs

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

@ -12,31 +12,20 @@
module Language.Haskell.Brittany.Internal.Types where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.Data
import qualified Data.Strict.Maybe as Strict
import qualified Safe
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan )
import Language.Haskell.GHC.ExactPrint ( AnnKey )
import Language.Haskell.GHC.ExactPrint.Types ( Anns )
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint (AnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Types (Anns)
import qualified Safe
data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe)
@ -44,14 +33,20 @@ data PerItemConfig = PerItemConfig
}
deriving Data.Data.Data
type PPM = MultiRWSS.MultiRWS
'[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String]
type PPM
= MultiRWSS.MultiRWS
'[ Map ExactPrint.AnnKey ExactPrint.Anns
, PerItemConfig
, Config
, ExactPrint.Anns
]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[]
type PPMLocal = MultiRWSS.MultiRWS
'[Config, ExactPrint.Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String]
type PPMLocal
= MultiRWSS.MultiRWS
'[Config , ExactPrint.Anns]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[]
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
@ -115,13 +110,20 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
instance Show LayoutState where
show state =
"LayoutState"
++ "{baseYs=" ++ show (_lstate_baseYs state)
++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
++ ",indLevels=" ++ show (_lstate_indLevels state)
++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
++ ",commentCol=" ++ show (_lstate_commentCol state)
++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
++ ",commentNewlines=" ++ show (_lstate_commentNewlines state)
++ "{baseYs="
++ show (_lstate_baseYs state)
++ ",curYOrAddNewline="
++ show (_lstate_curYOrAddNewline state)
++ ",indLevels="
++ show (_lstate_indLevels state)
++ ",indLevelLinger="
++ show (_lstate_indLevelLinger state)
++ ",commentCol="
++ show (_lstate_commentCol state)
++ ",addSepSpace="
++ show (_lstate_addSepSpace state)
++ ",commentNewlines="
++ show (_lstate_commentNewlines state)
++ "}"
-- data NewLineState = NewLineStateInit -- initial state. we do not know if in a
@ -223,12 +225,14 @@ data BrIndent = BrIndentNone
| BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show)
type ToBriDocM = MultiRWSS.MultiRWS
'[Config, Anns] -- reader
'[[BrittanyError], Seq String] -- writer
type ToBriDocM
= MultiRWSS.MultiRWS
'[Config , Anns] -- reader
'[[BrittanyError] , Seq String] -- writer
'[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc (sym :: Kind.Type -> Kind.Type)
= Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c
@ -340,17 +344,17 @@ type BriDocNumbered = (Int, BriDocFInt)
instance Uniplate.Uniplate BriDoc where
uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x
uniplate (BDSeq list ) = plate BDSeq ||* list
uniplate (BDSeq list) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd
uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts ) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x
uniplate (BDAnnotationPrior annKey bd) =
@ -361,14 +365,14 @@ instance Uniplate.Uniplate BriDoc where
plate BDAnnotationRest |- annKey |* bd
uniplate (BDMoveToKWDP annKey kw b bd) =
plate BDMoveToKWDP |- annKey |- kw |- b |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd
uniplate (BDLines lines) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd) = plate BDDebug |- s |* bd
newtype NodeAllocIndex = NodeAllocIndex Int
@ -421,7 +425,8 @@ briDocSeqSpine = \case
BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDPar _ind line indented ->
briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> ()
@ -456,8 +461,7 @@ data VerticalSpacingPar
-- product like (Normal|Always, None|Some Int).
deriving (Eq, Show)
data VerticalSpacing
= VerticalSpacing
data VerticalSpacing = VerticalSpacing
{ _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool
@ -467,7 +471,9 @@ data VerticalSpacing
newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
deriving (Functor, Applicative, Monad, Show, Alternative)
pattern LineModeValid :: forall t. t -> LineModeValidity t
pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid :: forall t. LineModeValidity t
pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
pattern LineModeValid :: forall t . t -> LineModeValidity t
pattern LineModeValid x =
LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid :: forall t . LineModeValidity t
pattern LineModeInvalid =
LineModeValidity Strict.Nothing :: LineModeValidity t

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

@ -7,39 +7,28 @@
module Language.Haskell.Brittany.Internal.Utils where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.ByteString as B
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.Utils as ExactPrint.Utils
import Data.Data
import Data.Generics.Aliases
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 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.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import qualified Text.PrettyPrint as PP
parDoc :: String -> PP.Doc
parDoc = PP.fsep . fmap PP.text . List.words
@ -55,7 +44,8 @@ showOutputable :: (GHC.Outputable a) => a -> String
showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
fromMaybeIdentity x y =
Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
fromOptionIdentity :: Identity a -> Maybe a -> Identity a
fromOptionIdentity x y =
@ -75,9 +65,11 @@ instance (Num a, Ord a) => Monoid (Max a) where
newtype ShowIsId = ShowIsId String deriving Data
instance Show ShowIsId where show (ShowIsId x) = x
instance Show ShowIsId where
show (ShowIsId x) = x
data A x = A ShowIsId x deriving Data
data A x = A ShowIsId x
deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF =
@ -99,14 +91,18 @@ customLayouterF anns layoutF =
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter
srcSpan ss =
simpleLayouter
-- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{" ++ showOutputable ss ++ "}"
$ "{"
++ showOutputable ss
++ "}"
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where
@ -135,10 +131,11 @@ customLayouterNoAnnsF layoutF =
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
@ -202,12 +199,11 @@ traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
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
tellDebugMessShow :: forall a m . (MonadMultiWriter
(Seq String) m, Show a) => a -> m ()
tellDebugMessShow
:: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show
-- i should really put that into multistate..
@ -230,20 +226,19 @@ briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
annsDoc =
printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], [])
breakEither fn (a1:aR) = case fn a1 of
breakEither fn (a1 : aR) = case fn a1 of
Left b -> (b : bs, 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 f (x1:xR) | Just y <- f x1 = (y : ys, xs)
where
(ys, xs) = spanMaybe f xR
spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs)
where (ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)
data FirstLastView a
@ -254,7 +249,7 @@ data FirstLastView a
splitFirstLast :: [a] -> FirstLastView a
splitFirstLast [] = FirstLastEmpty
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?
-- aka `transform`
@ -273,7 +268,7 @@ lines' :: String -> [String]
lines' s = case break (== '\n') s of
(s1, []) -> [s1]
(s1, [_]) -> [s1, ""]
(s1, (_:r)) -> s1 : lines' r
(s1, (_ : r)) -> s1 : lines' r
absurdExt :: HsExtension.NoExtCon -> a
absurdExt = HsExtension.noExtCon

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

@ -4,58 +4,41 @@
module Language.Haskell.Brittany.Main where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Control.Monad (zipWithM)
import qualified Control.Monad.Trans.Except as ExceptT
import Data.CZipWith
import qualified Data.Either
import qualified Data.List.Extra
import qualified Data.Monoid
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as TextL
import DataTreePrint
import GHC (GenLocated(L))
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List
import qualified System.IO
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Data.Monoid
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 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.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 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 Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Text.PrettyPrint as PP
import Text.Read (Read(..))
import UI.Butcher.Monadic
data WriteMode = Display | Inplace
@ -151,7 +134,8 @@ mainCmdParser helpDesc = do
printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty
noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty
configPaths <- addFlagStringParams ""
configPaths <- addFlagStringParams
""
["config-file"]
"PATH"
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
@ -181,7 +165,7 @@ mainCmdParser helpDesc = do
""
["write-mode"]
"(display|inplace)"
( flagHelp
(flagHelp
(PP.vcat
[ PP.text "display: output for any input(s) goes to stdout"
, PP.text "inplace: override respective input file (without backup!)"
@ -211,9 +195,11 @@ mainCmdParser helpDesc = do
$ ppHelpShallow helpDesc
System.Exit.exitSuccess
let inputPaths =
let
inputPaths =
if null inputParams then [Nothing] else map Just inputParams
let outputPaths = case writeMode of
let
outputPaths = case writeMode of
Display -> repeat Nothing
Inplace -> inputPaths
@ -235,7 +221,8 @@ mainCmdParser helpDesc = do
$ trace (showConfigYaml config)
$ return ()
results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode)
results <- zipWithM
(coreIO putStrErrLn config suppressOutput checkMode)
inputPaths
outputPaths
@ -266,7 +253,8 @@ coreIO
-> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status.
coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
ExceptT.runExceptT $ do
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
let
putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-- there is a good of code duplication between the following code and the
-- `pureModuleTransform` function. Unfortunately, there are also a good
@ -280,15 +268,18 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
-- string from the transformation output.
-- The flag is intentionally misspelled to prevent clashing with
-- inline-config stuff.
let hackAroundIncludes =
let
hackAroundIncludes =
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
let exactprintOnly = viaGlobal || viaDebug
let
exactprintOnly = viaGlobal || viaDebug
where
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
let
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting."
@ -304,14 +295,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
(parseResult, originalContents) <- case inputPathM of
Nothing -> do
-- TODO: refactor this hack to not be mixed into parsing logic
let hackF s = if "#include" `isPrefixOf` s
let
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s
else s
let hackTransform = if hackAroundIncludes && not exactprintOnly
let
hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines'
else id
inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString ghcOptions
parseRes <- liftIO $ parseModuleFromString
ghcOptions
"stdin"
cppCheckFunc
(hackTransform inputString)
@ -346,9 +340,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
pure c
let moduleConf = cZipWith fromOptionIdentity config inlineConf
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
let
val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return ()
let disableFormatting =
let
disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack
(errsWarns, outSText, hasChanges) <- do
if
@ -358,7 +354,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
pure ([], r, r /= originalContents)
| otherwise -> do
let omitCheck =
let
omitCheck =
moduleConf
& _conf_errorHandling
.> _econf_omit_output_valid_check
@ -366,14 +363,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
(ews, outRaw) <- if hasCPP || omitCheck
then return
$ pPrintModule moduleConf perItemConf anns parsedSource
else liftIO $ pPrintModuleAndCheck moduleConf
else liftIO $ pPrintModuleAndCheck
moduleConf
perItemConf
anns
parsedSource
let hackF s = fromMaybe s $ TextL.stripPrefix
let
hackF s = fromMaybe s $ TextL.stripPrefix
(TextL.pack "-- BRITANY_INCLUDE_HACK ")
s
let out = TextL.toStrict $ if hackAroundIncludes
let
out = TextL.toStrict $ if hackAroundIncludes
then
TextL.intercalate (TextL.pack "\n")
$ hackF
@ -383,14 +383,16 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
then lift $ obfuscate out
else pure out
pure $ (ews, out', out' /= originalContents)
let customErrOrder ErrorInput{} = 4
let
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do
let groupedErrsWarns =
let
groupedErrsWarns =
Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder
$ errsWarns
@ -406,9 +408,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ "WARNING: encountered unknown syntactical constructs:"
uns `forM_` \case
ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc)
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe
(ppr loc)
when
( config
(config
& _conf_debug
& _dconf_dump_ast_unknown
& confUnpack
@ -460,7 +463,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ case outputPathM of
Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do
let isIdentical = case inputPathM of
let
isIdentical = case inputPathM of
Nothing -> False
Just _ -> not hasChanges
unless isIdentical $ Text.IO.writeFile p $ outSText

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

@ -2,35 +2,24 @@
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Language.Haskell.Brittany.Internal.Prelude
import Data.Coerce (coerce)
import Data.List (groupBy)
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified GHC.OldList as List
import qualified System.Directory
import Test.Hspec
import qualified Text.Parsec as Parsec
import Text.Parsec.Text ( Parser )
import Data.List ( groupBy )
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config
import Data.Coerce ( coerce )
import qualified Data.Text.IO as Text.IO
import System.FilePath ( (</>) )
import System.Timeout ( timeout )
import 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 System.FilePath ((</>))
import System.Timeout (timeout)
import Test.Hspec
import qualified Text.Parsec as Parsec
import Text.Parsec.Text (Parser)
hush :: Either a b -> Maybe b
hush = either (const Nothing) Just
@ -47,8 +36,7 @@ asymptoticPerfTest = do
$ roundTripEqualWithTimeout 4000000
$ (Text.pack "func = ")
<> mconcat
( [1 .. 10]
<&> \(i :: Int) ->
([1 .. 10] <&> \(i :: Int) ->
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
)
<> Text.replicate 2000 (Text.pack " ")
@ -62,9 +50,10 @@ asymptoticPerfTest = do
roundTripEqualWithTimeout :: Int -> Text -> Expectation
roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
where
action = fmap (fmap PPTextWrapper)
action = fmap
(fmap PPTextWrapper)
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
@ -85,7 +74,8 @@ data TestCase = TestCase
main :: IO ()
main = do
files <- System.Directory.listDirectory "data/"
let blts =
let
blts =
List.sort
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
$ filter (".blt" `isSuffixOf`) files
@ -99,8 +89,10 @@ main = do
it "gives properly formatted result for valid input" $ do
let
input = Text.pack $ unlines
["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"]
let expected = Text.pack $ unlines
[ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"
]
let
expected = Text.pack $ unlines
[ "func ="
, " [ 00000000000000000000000"
, " , 00000000000000000000000"
@ -154,13 +146,16 @@ main = do
testProcessor = \case
HeaderLine n : rest ->
let normalLines = Data.Maybe.mapMaybe extractNormal rest
in TestCase
in
TestCase
{ testName = n
, isPending = any isPendingLine rest
, content = Text.unlines normalLines
}
l ->
error $ "first non-empty line must start with #test footest\n" ++ show l
error
$ "first non-empty line must start with #test footest\n"
++ show l
extractNormal (NormalLine l) = Just l
extractNormal _ = Nothing
isPendingLine PendingLine{} = True
@ -225,7 +220,6 @@ instance Show PPTextWrapper where
show (PPTextWrapper t) = "\n" ++ Text.unpack t
-- brittany-next-binding --columns 160
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
defaultTestConfig :: Config
defaultTestConfig = Config
{ _conf_version = _conf_version staticDefaultConfig