Format Brittany with Brittany #359
|
|
@ -86,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
|
||||
|
|
@ -122,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 }
|
||||
|
|
@ -142,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 }
|
||||
|
|
@ -150,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 }
|
||||
|
|
@ -172,7 +178,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
|
|||
Right c -> Right $ c
|
||||
pure (k, r)
|
||||
|
||||
let perModule = foldl'
|
||||
let
|
||||
perModule = foldl'
|
||||
(<>)
|
||||
mempty
|
||||
[ conf
|
||||
|
|
@ -232,20 +239,22 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
|
|||
-- won't do.
|
||||
parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
|
||||
parsePrintModule configWithDebugs inputText = runExceptT $ do
|
||||
let config =
|
||||
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
|
||||
let
|
||||
config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
|
||||
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
|
||||
let config_pp = config & _conf_preprocessor
|
||||
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
|
||||
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
|
||||
(anns, parsedSource, hasCPP) <- do
|
||||
let hackF s = if "#include" `isPrefixOf` s
|
||||
then "-- BRITANY_INCLUDE_HACK " ++ s
|
||||
else s
|
||||
let hackTransform = if hackAroundIncludes
|
||||
let
|
||||
hackF s =
|
||||
if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s
|
||||
let
|
||||
hackTransform = if hackAroundIncludes
|
||||
then List.intercalate "\n" . fmap hackF . lines'
|
||||
else id
|
||||
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
|
||||
let
|
||||
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
|
||||
then case cppMode of
|
||||
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
|
||||
CPPModeWarn -> return $ Right True
|
||||
|
|
@ -269,7 +278,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
|
||||
|
|
@ -278,23 +288,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)
|
||||
|
|
@ -315,7 +328,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
|
||||
|
|
@ -351,11 +365,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)
|
||||
|
|
@ -379,7 +395,8 @@ parsePrintModuleTests conf filename input = do
|
|||
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
|
||||
|
|
@ -458,20 +475,21 @@ 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 defaultAnns $
|
||||
Map.findWithDefault Map.empty declAnnKey annMap
|
||||
filteredAnns <- mAsk <&> \annMap ->
|
||||
Map.union defaultAnns $ 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
|
||||
|
|
@ -487,7 +505,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
|
||||
|
|
@ -498,10 +517,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)
|
||||
|
|
@ -530,7 +549,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
|
||||
|
|
@ -554,9 +574,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
|
|||
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'
|
||||
|
||||
|
|
@ -602,7 +622,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
|
||||
|
|
@ -628,7 +649,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
|
||||
|
|
@ -643,7 +666,8 @@ layoutBriDoc briDoc = do
|
|||
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
|
||||
let remainingComments =
|
||||
let
|
||||
remainingComments =
|
||||
[ c
|
||||
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
|
||||
(_lstate_comments state')
|
||||
|
|
|
|||
|
|
@ -39,8 +39,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
|
||||
|
|
@ -50,15 +54,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
|
||||
|
|
@ -84,7 +91,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
|
||||
|
|
@ -102,7 +110,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
|
||||
|
|
@ -111,7 +120,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
|
||||
|
|
@ -125,7 +135,8 @@ layoutBriDocM = \case
|
|||
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
|
||||
|
|
@ -148,7 +159,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
|
||||
|
|
@ -170,7 +182,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
|
||||
|
|
@ -186,14 +199,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
|
||||
|
|
@ -207,12 +222,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
|
||||
|
|
@ -226,18 +243,23 @@ layoutBriDocM = \case
|
|||
let m = _lstate_comments state
|
||||
pure $ Map.lookup annKey m
|
||||
let mComments = nonEmpty . extractAllComments =<< annMay
|
||||
let semiCount = length [ ()
|
||||
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
|
||||
}
|
||||
|
|
@ -250,7 +272,8 @@ layoutBriDocM = \case
|
|||
when shouldAddSemicolonNewlines $ do
|
||||
[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
|
||||
|
|
@ -270,7 +293,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
|
||||
|
|
@ -478,8 +503,8 @@ 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
|
||||
[] -> []
|
||||
|
|
@ -501,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
|
||||
|
|
@ -539,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
|
||||
|
|
@ -572,8 +595,7 @@ 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 ..]
|
||||
|
|
@ -593,14 +615,14 @@ 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 =
|
||||
let
|
||||
isLastList =
|
||||
if lastFlag then (== length list) <$> [1 ..] else repeat False
|
||||
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
|
||||
let lengthInfos = zip (briDocLineLength <$> list) subInfos
|
||||
|
|
@ -648,7 +670,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
|
||||
|
|
@ -662,7 +685,8 @@ 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
|
||||
let
|
||||
fixedPosXs = case alignMode of
|
||||
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)
|
||||
where
|
||||
factor :: Float =
|
||||
|
|
@ -673,15 +697,16 @@ processInfo maxSpace m = \case
|
|||
offsets = (subtract curX) <$> posXs
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -22,17 +22,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
|||
|
||||
|
||||
|
||||
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
|
||||
|
|
@ -54,9 +49,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
|
||||
|
|
@ -68,9 +61,7 @@ layoutWriteAppendSpaces i = do
|
|||
}
|
||||
|
||||
layoutWriteAppendMultiline
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
)
|
||||
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
|
||||
=> [Text]
|
||||
-> m ()
|
||||
layoutWriteAppendMultiline ts = do
|
||||
|
|
@ -85,14 +76,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
|
||||
}
|
||||
|
||||
|
|
@ -110,11 +100,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)
|
||||
|
|
@ -124,9 +114,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
|
||||
|
|
@ -144,8 +132,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)
|
||||
|
|
@ -156,9 +143,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")
|
||||
|
|
@ -175,9 +160,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")
|
||||
|
|
@ -191,61 +174,52 @@ 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
|
||||
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 ()
|
||||
layoutIndentLevelPushInternal :: (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 = do
|
||||
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
|
||||
}
|
||||
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }
|
||||
|
||||
layoutWithAddBaseCol
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
|
|
@ -277,9 +251,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 ()
|
||||
|
|
@ -292,9 +264,7 @@ 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")
|
||||
|
|
@ -310,9 +280,7 @@ layoutWriteEnsureBlock = 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 ()
|
||||
|
|
@ -322,8 +290,7 @@ layoutWithAddBaseColN amount m = do
|
|||
m
|
||||
layoutBaseYPopInternal
|
||||
|
||||
layoutBaseYPushCur
|
||||
:: (MonadMultiState LayoutState m) => m ()
|
||||
layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
|
||||
layoutBaseYPushCur = do
|
||||
traceLocal ("layoutBaseYPushCur")
|
||||
state <- mGet
|
||||
|
|
@ -335,26 +302,24 @@ layoutBaseYPushCur = do
|
|||
(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
|
||||
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
|
||||
|
|
@ -364,12 +329,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.
|
||||
|
|
@ -393,16 +358,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
|
||||
}
|
||||
|
|
@ -415,9 +380,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 " "
|
||||
|
|
@ -437,17 +400,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
|
||||
|
|
@ -456,10 +420,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
|
||||
|
|
@ -467,8 +434,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
|
||||
}
|
||||
|
|
@ -477,30 +444,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,
|
||||
|
|
|
|||
|
|
@ -235,7 +235,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
|
||||
|
|
@ -261,8 +262,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,7 +36,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.
|
||||
|
|
@ -141,12 +141,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)
|
||||
|
|
@ -161,13 +161,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)
|
||||
|
|
@ -187,9 +187,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
|
||||
|
|
|
|||
|
|
@ -104,16 +104,26 @@ 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.
|
||||
|
|
|
|||
|
|
@ -53,13 +53,16 @@ parseModuleFromString = ParseModule.parseModule
|
|||
|
||||
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
|
||||
commentAnnFixTransformGlob ast = do
|
||||
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
|
||||
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)
|
||||
|
|
@ -70,7 +73,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
|
||||
|
|
@ -97,15 +101,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'
|
||||
}
|
||||
|
|
@ -200,7 +205,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)
|
||||
|
|
@ -215,10 +221,10 @@ foldedAnnKeys ast = SYB.everything
|
|||
[ 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 () ()))
|
||||
|
|
@ -238,7 +244,8 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
|
|||
pure x
|
||||
where
|
||||
f anns =
|
||||
let ((), (annsBalanced, _), _) =
|
||||
let
|
||||
((), (annsBalanced, _), _) =
|
||||
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
|
||||
in annsBalanced
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,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
|
||||
|
|
@ -84,7 +85,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
|
||||
|
|
@ -99,21 +101,23 @@ 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
|
||||
|
|
@ -141,7 +145,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
|
||||
|
|
@ -167,7 +172,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
|
||||
|
|
@ -188,7 +194,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
|
||||
|
|
@ -212,8 +219,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
|
||||
|
|
@ -231,7 +237,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
|
||||
|
|
@ -449,16 +456,13 @@ 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) =
|
||||
docAlt $ Writer.execWriter action
|
||||
runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action
|
||||
|
||||
|
||||
docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
||||
|
|
@ -506,7 +510,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
|
||||
|
|
@ -620,17 +625,11 @@ 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
|
||||
|
|
@ -767,7 +766,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)
|
||||
|
|
|
|||
|
|
@ -27,9 +27,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
|
||||
|
|
@ -69,8 +70,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
|
||||
|
|
@ -82,11 +83,13 @@ 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
|
||||
|
|
@ -94,7 +97,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
|||
]
|
||||
]
|
||||
(Just forallDoc, Nothing) -> docLines
|
||||
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
|
||||
[ docSeq
|
||||
[docLitS "=", docSeparator, docForceSingleline forallDoc]
|
||||
, docSeq [docLitS ".", docSeparator, rhsDoc]
|
||||
]
|
||||
(Nothing, Just rhsContextDoc) -> docSeq
|
||||
|
|
@ -102,12 +106,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
|
||||
|
|
@ -119,7 +123,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 "."
|
||||
|
|
@ -132,8 +137,7 @@ 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
|
||||
|
|
@ -146,7 +150,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 "."
|
||||
|
|
@ -162,8 +167,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
|
||||
|
|
@ -187,10 +191,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
|||
(docLines
|
||||
[ lhsContextDoc
|
||||
, docNodeAnnKW ltycl (Just GHC.AnnData)
|
||||
$ docSeq
|
||||
[ appSep $ docLit nameStr
|
||||
, tyVarLine
|
||||
]
|
||||
$ docSeq [appSep $ docLit nameStr, tyVarLine]
|
||||
, consDoc
|
||||
]
|
||||
)
|
||||
|
|
@ -209,15 +210,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]
|
||||
]
|
||||
]
|
||||
|
|
@ -229,10 +230,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,11 +262,10 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
|
|||
(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
|
||||
whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
|
||||
(lhsStrategy, rhsStrategy) =
|
||||
maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
|
||||
in docSeq
|
||||
[ docDeriving
|
||||
, docWrapNodePrior types $ lhsStrategy
|
||||
, docSeparator
|
||||
|
|
@ -275,7 +273,8 @@ 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
|
||||
|
|
@ -288,11 +287,8 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
|
|||
lVia@(L _ (ViaStrategy viaTypes)) ->
|
||||
( docEmpty
|
||||
, case viaTypes of
|
||||
HsIB _ext t -> docSeq
|
||||
[ docWrapNode lVia $ docLitS " via"
|
||||
, docSeparator
|
||||
, layoutType t
|
||||
]
|
||||
HsIB _ext t ->
|
||||
docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
|
||||
)
|
||||
|
||||
docDeriving :: ToBriDocM BriDocNumbered
|
||||
|
|
@ -310,13 +306,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
|
||||
|
|
@ -330,14 +329,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 (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
|
||||
|
|
@ -366,7 +364,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]
|
||||
|
|
@ -382,7 +381,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]
|
||||
|
|
@ -413,10 +413,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
|
||||
|
|
@ -426,12 +427,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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -64,14 +64,16 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
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
|
||||
|
|
@ -79,24 +81,29 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
<> nameStr
|
||||
<> Text.pack " #-}"
|
||||
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ
|
||||
PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") 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
|
||||
|
|
@ -125,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]
|
||||
]
|
||||
|
|
@ -137,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
|
||||
|
|
@ -157,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
|
||||
|
|
@ -177,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)
|
||||
|
|
@ -195,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
|
||||
|
|
@ -205,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
|
||||
|
|
@ -235,15 +245,16 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
|
|||
let mIdStr' = fixPatternBindIdentifier match <$> mIdStr
|
||||
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
|
||||
(Just idStr, p1 : p2 : pr) | isInfix -> if null pr
|
||||
then
|
||||
docCols ColPatternsFuncInfix
|
||||
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
|
||||
|
|
@ -266,15 +277,15 @@ 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
|
||||
|
|
@ -300,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
|
||||
|
|
@ -353,13 +362,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
|
||||
|
|
@ -371,10 +383,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
|
|||
]
|
||||
_ -> Nothing
|
||||
|
||||
indentPolicy <- mAsk
|
||||
<&> _conf_layout
|
||||
.> _lconfig_indentPolicy
|
||||
.> confUnpack
|
||||
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
|
||||
|
||||
runFilteredAlternative $ do
|
||||
|
||||
|
|
@ -400,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
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
@ -410,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;
|
||||
|
|
@ -422,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
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
@ -514,8 +526,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
|
|||
$ (case guardDocs of
|
||||
[] -> []
|
||||
[g] ->
|
||||
[ docForceSingleline
|
||||
$ docSeq [appSep $ docLit $ Text.pack "|", return g]
|
||||
[ docForceSingleline $ docSeq
|
||||
[appSep $ docLit $ Text.pack "|", return g]
|
||||
]
|
||||
gs ->
|
||||
[ docForceSingleline
|
||||
|
|
@ -579,14 +591,11 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
|
|||
>>= \(guardDocs, bodyDoc, _) ->
|
||||
(case guardDocs of
|
||||
[] -> []
|
||||
[g] ->
|
||||
[docSeq [appSep $ docLit $ Text.pack "|", return g]]
|
||||
[g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]]
|
||||
(g1 : gr) ->
|
||||
(docSeq [appSep $ docLit $ Text.pack "|", return g1]
|
||||
: ( gr
|
||||
<&> \g ->
|
||||
docSeq
|
||||
[appSep $ docLit $ Text.pack ",", return g]
|
||||
: (gr <&> \g ->
|
||||
docSeq [appSep $ docLit $ Text.pack ",", return g]
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
@ -607,39 +616,45 @@ 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
|
||||
|
|
@ -663,18 +678,21 @@ layoutLPatSyn name (InfixCon left right) = do
|
|||
layoutLPatSyn name (RecCon recArgs) = do
|
||||
docName <- lrdrNameToTextAnn name
|
||||
args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs
|
||||
docSeq . fmap docLit
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -684,7 +702,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
|
||||
|
|
@ -715,9 +734,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
|
||||
|
|
@ -787,8 +804,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
|
|||
makeForallDoc bndrs = do
|
||||
bndrDocs <- layoutTyVarBndrs bndrs
|
||||
docSeq
|
||||
( [docLit (Text.pack "forall")]
|
||||
++ processTyVarBndrsSingleline bndrDocs
|
||||
([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs
|
||||
)
|
||||
lhs =
|
||||
docWrapNode innerNode
|
||||
|
|
@ -799,14 +815,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]
|
||||
|
|
@ -856,7 +874,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
|
||||
|
|
@ -937,7 +959,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')
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -49,22 +49,26 @@ 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
|
||||
|
|
@ -90,16 +94,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 <-
|
||||
|
|
@ -139,7 +146,8 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
|
|||
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
|
||||
= L
|
||||
l
|
||||
(IEThingWith x
|
||||
(IEThingWith
|
||||
x
|
||||
wn
|
||||
NoIEWildcard
|
||||
(consItems1 ++ consItems2)
|
||||
|
|
@ -162,7 +170,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
|
||||
|
|
@ -211,4 +220,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)
|
||||
|
|
|
|||
|
|
@ -30,7 +30,8 @@ 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
|
||||
importAsCol <-
|
||||
mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
|
||||
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
|
||||
let
|
||||
compact = indentPolicy /= IndentPolicyFree
|
||||
|
|
@ -40,10 +41,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
|
||||
|
|
@ -52,20 +56,22 @@ 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
|
||||
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
|
||||
|
|
@ -73,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)
|
||||
|
|
@ -87,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)
|
||||
|
|
@ -102,13 +118,16 @@ layoutImport importD = case importD of
|
|||
]
|
||||
addAlternative $ docPar
|
||||
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
|
||||
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
|
||||
(docEnsureIndent
|
||||
(BrIndentSpecial hidDocColDiff)
|
||||
docParenR
|
||||
)
|
||||
-- ..[hiding].( b
|
||||
-- , b'
|
||||
-- )
|
||||
(ieD:ieDs') ->
|
||||
docPar
|
||||
(docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]])
|
||||
(ieD : ieDs') -> docPar
|
||||
(docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]
|
||||
)
|
||||
(docEnsureIndent (BrIndentSpecial hidDocColDiff)
|
||||
$ docLines
|
||||
$ ieDs'
|
||||
|
|
@ -119,21 +138,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]
|
||||
|
|
|
|||
|
|
@ -36,10 +36,8 @@ 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
|
||||
|
|
@ -49,9 +47,7 @@ layoutModule lmod@(L _ mod') = case mod' of
|
|||
-- 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
|
||||
|
|
@ -60,13 +56,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
|
||||
|
|
@ -97,7 +91,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
|
||||
|
|
@ -116,7 +111,8 @@ transformToCommentedImport is = do
|
|||
accumF accConnectedComm (annMay, decl) = case annMay of
|
||||
Nothing ->
|
||||
( []
|
||||
, [ ImportStatement ImportStatementRecord { commentsBefore = []
|
||||
, [ ImportStatement ImportStatementRecord
|
||||
{ commentsBefore = []
|
||||
, commentsAfter = []
|
||||
, importStatement = decl
|
||||
}
|
||||
|
|
@ -195,10 +191,7 @@ 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)
|
||||
|
|
|
|||
|
|
@ -33,11 +33,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
|
||||
|
|
@ -67,10 +65,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
|
||||
|
|
@ -96,8 +93,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 "="
|
||||
|
|
@ -110,11 +106,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
|
||||
|
|
@ -189,9 +183,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
|
||||
|
|
@ -213,8 +205,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
|
||||
|
|
|
|||
|
|
@ -62,7 +62,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
|
||||
]
|
||||
|
|
@ -78,7 +79,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
|
||||
|
|
@ -89,7 +91,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
|
||||
|
|
|
|||
|
|
@ -24,43 +24,32 @@ 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"
|
||||
[ 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 "()"
|
||||
|
|
@ -69,20 +58,17 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
[ let
|
||||
open = docLit $ Text.pack "("
|
||||
close = docLit $ Text.pack ")"
|
||||
list = List.intersperse docCommaSep
|
||||
$ docForceSingleline <$> cntxtDocs
|
||||
list =
|
||||
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
|
||||
in docSeq ([open] ++ list ++ [close])
|
||||
, let
|
||||
open = docCols ColTyOpPrefix
|
||||
[ docParenLSep
|
||||
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
|
||||
]
|
||||
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
|
||||
|
|
@ -90,7 +76,8 @@ 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])
|
||||
|
|
@ -105,12 +92,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
, docPar
|
||||
forallDoc
|
||||
(docLines
|
||||
[ docCols ColTyOpPrefix
|
||||
[ 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
|
||||
]
|
||||
|
|
@ -121,7 +109,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
|
||||
|
|
@ -130,7 +119,8 @@ 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])
|
||||
|
|
@ -140,7 +130,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
-- . x
|
||||
, docPar
|
||||
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
|
||||
( docCols ColTyOpPrefix
|
||||
(docCols
|
||||
ColTyOpPrefix
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
|
||||
, maybeForceML $ return typeDoc
|
||||
]
|
||||
|
|
@ -152,21 +143,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
|
||||
]
|
||||
|
|
@ -184,25 +170,21 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
[ let
|
||||
open = docLit $ Text.pack "("
|
||||
close = docLit $ Text.pack ")"
|
||||
list = List.intersperse docCommaSep
|
||||
$ docForceSingleline <$> cntxtDocs
|
||||
list =
|
||||
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
|
||||
in docSeq ([open] ++ list ++ [close])
|
||||
, let
|
||||
open = docCols ColTyOpPrefix
|
||||
[ docParenLSep
|
||||
, docAddBaseY (BrIndentSpecial 2)
|
||||
$ head cntxtDocs
|
||||
]
|
||||
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]
|
||||
]
|
||||
let maybeForceML = case typ1 of
|
||||
let
|
||||
maybeForceML = case typ1 of
|
||||
(L _ HsFunTy{}) -> docForceMultiline
|
||||
_ -> id
|
||||
docAlt
|
||||
|
|
@ -217,7 +199,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
|
||||
]
|
||||
|
|
@ -226,24 +209,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
|
||||
]
|
||||
)
|
||||
]
|
||||
|
|
@ -256,14 +240,18 @@ 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
|
||||
final -> (final, list)
|
||||
|
|
@ -272,8 +260,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
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
|
||||
|
|
@ -281,13 +269,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
typeDoc2 <- docSharedWrapper layoutType typ2
|
||||
docAlt
|
||||
[ docSeq
|
||||
[ docForceSingleline typeDoc1
|
||||
, docSeparator
|
||||
, docForceSingleline typeDoc2
|
||||
]
|
||||
, docPar
|
||||
typeDoc1
|
||||
(docEnsureIndent BrIndentRegular typeDoc2)
|
||||
[docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
|
||||
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
|
||||
]
|
||||
HsListTy _ typ1 -> do
|
||||
typeDoc1 <- docSharedWrapper layoutType typ1
|
||||
|
|
@ -298,10 +281,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
|
||||
|
|
@ -310,38 +295,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)
|
||||
|
|
@ -411,20 +404,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
|
||||
|
|
@ -563,15 +554,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]
|
||||
]
|
||||
|
|
@ -584,8 +579,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
|
||||
|
|
@ -603,9 +597,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
|
||||
|
|
|
|||
|
|
@ -18,7 +18,8 @@ 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
|
||||
|
|
|
|||
|
|
@ -27,12 +27,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 (<$!>)
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ data AltCurPos = AltCurPos
|
|||
, _acp_indentPrep :: Int -- indentChange affecting the next Par
|
||||
, _acp_forceMLFlag :: AltLineModeState
|
||||
}
|
||||
deriving (Show)
|
||||
deriving Show
|
||||
|
||||
data AltLineModeState
|
||||
= AltLineModeStateNone
|
||||
|
|
@ -44,7 +44,8 @@ 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
|
||||
|
|
@ -114,7 +115,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
|
||||
|
|
@ -125,10 +132,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
|
||||
|
|
@ -157,22 +162,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
|
||||
|
|
@ -187,7 +188,8 @@ transformAlts =
|
|||
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
|
||||
|
|
@ -197,35 +199,41 @@ 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
|
||||
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)] =
|
||||
(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") $
|
||||
|
|
@ -250,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 }
|
||||
|
|
@ -259,7 +269,8 @@ 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 ->
|
||||
|
|
@ -273,10 +284,7 @@ transformAlts =
|
|||
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')
|
||||
BDFEnsureIndent indent bd -> do
|
||||
|
|
@ -297,14 +305,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
|
||||
|
|
@ -320,7 +335,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"
|
||||
|
|
@ -328,8 +344,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)
|
||||
|
||||
|
|
@ -348,10 +369,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
|
||||
|
|
@ -360,9 +382,12 @@ 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
|
||||
|
|
@ -370,11 +395,8 @@ getSpacing !bridoc = rec bridoc
|
|||
BrIndentSpecial j -> i + j
|
||||
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
|
||||
BrIndentNone -> i
|
||||
BrIndentRegular -> i + ( confUnpack
|
||||
$ _lconfig_indentAmount
|
||||
$ _conf_layout
|
||||
$ config
|
||||
)
|
||||
BrIndentRegular ->
|
||||
i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config)
|
||||
BrIndentSpecial j -> i + j
|
||||
}
|
||||
BDFBaseYPushCur bd -> do
|
||||
|
|
@ -385,11 +407,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
|
||||
|
|
@ -403,12 +427,19 @@ 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"
|
||||
|
|
@ -435,35 +466,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 [] ->
|
||||
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
|
||||
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
|
||||
|
|
@ -473,16 +502,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) ->
|
||||
|
|
@ -492,9 +534,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
|
||||
|
|
@ -509,7 +556,8 @@ getSpacing !bridoc = rec bridoc
|
|||
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
|
||||
VerticalSpacingParAlways $ i + j
|
||||
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
|
||||
VerticalSpacingParSome $ x + y)
|
||||
VerticalSpacingParSome $ x + y
|
||||
)
|
||||
x3
|
||||
singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone
|
||||
singleline _ = False
|
||||
|
|
@ -548,12 +596,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
rec (brDcId, brdc) = memoWithKey brDcId $ do
|
||||
config <- mAsk
|
||||
let colMax = config & _conf_layout & _lconfig_cols & confUnpack
|
||||
let hasOkColCount (VerticalSpacing lsp psp _) =
|
||||
lsp <= colMax && case psp of
|
||||
let
|
||||
hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of
|
||||
VerticalSpacingParNone -> True
|
||||
VerticalSpacingParSome i -> i <= colMax
|
||||
VerticalSpacingParAlways{} -> True
|
||||
let specialCompare vs1 vs2 =
|
||||
let
|
||||
specialCompare vs1 vs2 =
|
||||
if ((_vs_sameLine vs1 == _vs_sameLine vs2)
|
||||
&& (_vs_parFlag vs1 == _vs_parFlag vs2)
|
||||
)
|
||||
|
|
@ -562,11 +611,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
|
||||
|
|
@ -586,7 +633,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
|
||||
|
|
@ -618,24 +666,23 @@ 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
|
||||
BDFCols _sig list ->
|
||||
fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
|
||||
BDFSeparator ->
|
||||
return $ [VerticalSpacing 1 VerticalSpacingParNone False]
|
||||
BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
|
||||
BDFCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
|
||||
BDFSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False]
|
||||
BDFAddBaseY indent bd -> do
|
||||
mVs <- rec bd
|
||||
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
|
||||
|
|
@ -643,11 +690,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
BrIndentSpecial j -> i + j
|
||||
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
|
||||
BrIndentNone -> i
|
||||
BrIndentRegular -> i + ( confUnpack
|
||||
$ _lconfig_indentAmount
|
||||
$ _conf_layout
|
||||
$ config
|
||||
)
|
||||
BrIndentRegular ->
|
||||
i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config)
|
||||
BrIndentSpecial j -> i + j
|
||||
}
|
||||
BDFBaseYPushCur bd -> do
|
||||
|
|
@ -658,11 +702,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
|
||||
|
|
@ -674,13 +720,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
|
||||
|
|
@ -688,9 +729,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
|
||||
)
|
||||
|
||||
|
|
@ -709,20 +753,15 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
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
|
||||
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)
|
||||
(VerticalSpacingParAlways 0)
|
||||
True
|
||||
[t1] ->
|
||||
VerticalSpacing (Text.length t1) VerticalSpacingParNone False
|
||||
(t1 : _) ->
|
||||
VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True
|
||||
| allowHangingQuasiQuotes
|
||||
]
|
||||
BDFAnnotationPrior _annKey bd -> rec bd
|
||||
|
|
@ -737,14 +776,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
-- 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
|
||||
|
|
@ -760,12 +798,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
|
||||
|
|
@ -776,9 +813,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
|
||||
|
|
@ -827,16 +866,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
|
||||
|
|
@ -848,8 +896,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,7 +915,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
VerticalSpacingParAlways $ i + j
|
||||
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
|
||||
VerticalSpacingParAlways $ i + j
|
||||
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)
|
||||
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
|
||||
VerticalSpacingParSome $ x + y
|
||||
)
|
||||
x3
|
||||
singleline x = _vs_paragraph x == VerticalSpacingParNone
|
||||
isPar x = _vs_parFlag x
|
||||
|
|
@ -888,7 +940,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
|
||||
|
|
@ -898,7 +951,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
|
||||
|
|
|
|||
|
|
@ -16,19 +16,35 @@ 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
|
||||
| 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
|
||||
|
|
@ -42,15 +58,30 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
|
|||
BDAnnotationRest annKey1 (BDSeq list) ->
|
||||
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
|
||||
BDAnnotationRest annKey1 (BDLines list) ->
|
||||
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
|
||||
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.
|
||||
|
|
@ -60,48 +91,46 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
|
|||
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
|
||||
, 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 ->
|
||||
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)
|
||||
| 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])
|
||||
| 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
|
||||
$ 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
|
||||
|
|
|
|||
|
|
@ -16,7 +16,8 @@ import Language.Haskell.Brittany.Internal.Utils
|
|||
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"
|
||||
|
||||
|
||||
|
|
@ -48,11 +49,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) ->
|
||||
|
|
@ -63,11 +73,20 @@ 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) ->
|
||||
|
|
@ -76,14 +95,12 @@ transformSimplifyFloating = stepBO .> stepFull
|
|||
descendBYPush = transformDownMay $ \case
|
||||
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@(_ : _)) ->
|
||||
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@(_ : _)) ->
|
||||
|
|
@ -94,12 +111,10 @@ transformSimplifyFloating = stepBO .> stepFull
|
|||
descendILPop = transformDownMay $ \case
|
||||
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
|
||||
|
|
@ -117,14 +132,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) ->
|
||||
|
|
@ -148,8 +160,7 @@ 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
|
||||
|
|
@ -161,12 +172,10 @@ transformSimplifyFloating = stepBO .> stepFull
|
|||
-- 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
|
||||
|
|
@ -187,9 +196,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
|
||||
|
|
|
|||
|
|
@ -27,13 +27,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
|
||||
|
|
|
|||
|
|
@ -21,12 +21,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
|
||||
|
|
|
|||
|
|
@ -66,9 +66,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 =
|
||||
|
|
@ -93,11 +95,15 @@ customLayouterF anns layoutF =
|
|||
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
|
||||
|
|
@ -129,7 +135,8 @@ customLayouterNoAnnsF layoutF =
|
|||
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
|
||||
|
|
@ -193,12 +200,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..
|
||||
|
|
@ -221,20 +227,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
|
||||
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
|
||||
where (ys, xs) = spanMaybe f xR
|
||||
spanMaybe _ xs = ([], xs)
|
||||
|
||||
data FirstLastView a
|
||||
|
|
|
|||
|
|
@ -146,7 +146,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 ?
|
||||
|
|
@ -206,9 +207,10 @@ mainCmdParser helpDesc = do
|
|||
$ ppHelpShallow helpDesc
|
||||
System.Exit.exitSuccess
|
||||
|
||||
let inputPaths =
|
||||
if null inputParams then [Nothing] else map Just inputParams
|
||||
let outputPaths = case writeMode of
|
||||
let
|
||||
inputPaths = if null inputParams then [Nothing] else map Just inputParams
|
||||
let
|
||||
outputPaths = case writeMode of
|
||||
Display -> repeat Nothing
|
||||
Inplace -> inputPaths
|
||||
|
||||
|
|
@ -230,7 +232,8 @@ mainCmdParser helpDesc = do
|
|||
$ trace (showConfigYaml config)
|
||||
$ return ()
|
||||
|
||||
results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode)
|
||||
results <- zipWithM
|
||||
(coreIO putStrErrLn config suppressOutput checkMode)
|
||||
inputPaths
|
||||
outputPaths
|
||||
|
||||
|
|
@ -275,15 +278,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."
|
||||
|
|
@ -299,14 +305,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)
|
||||
|
|
@ -343,7 +352,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
|
|||
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
|
||||
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
|
||||
|
|
@ -353,7 +363,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
|
||||
|
|
@ -361,14 +372,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
|
||||
|
|
@ -378,14 +392,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
|
||||
|
|
@ -455,7 +471,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
|
||||
|
|
|
|||
Loading…
Reference in New Issue