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

Refactor module structure; Clean up imports

pull/3/head
Lennart Spitzner 2016-09-04 00:24:20 +02:00
parent 9d4192df00
commit a29836d09c
23 changed files with 2447 additions and 2421 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
brittany.cabal
View File

@ -34,14 +34,20 @@ library {
Language.Haskell.Brittany.Config.Types Language.Haskell.Brittany.Config.Types
} }
other-modules: { other-modules: {
Language.Haskell.Brittany.LayoutBasics Language.Haskell.Brittany.LayouterBasics
Language.Haskell.Brittany.BriLayouter Language.Haskell.Brittany.BackendUtils
Language.Haskell.Brittany.Backend
Language.Haskell.Brittany.ExactPrintUtils Language.Haskell.Brittany.ExactPrintUtils
Language.Haskell.Brittany.Layouters.Type Language.Haskell.Brittany.Layouters.Type
Language.Haskell.Brittany.Layouters.Decl Language.Haskell.Brittany.Layouters.Decl
Language.Haskell.Brittany.Layouters.Expr Language.Haskell.Brittany.Layouters.Expr
Language.Haskell.Brittany.Layouters.Stmt Language.Haskell.Brittany.Layouters.Stmt
Language.Haskell.Brittany.Layouters.Pattern Language.Haskell.Brittany.Layouters.Pattern
Language.Haskell.Brittany.Transformations.Alt
Language.Haskell.Brittany.Transformations.Floating
Language.Haskell.Brittany.Transformations.Par
Language.Haskell.Brittany.Transformations.Columns
Language.Haskell.Brittany.Transformations.Indent
} }
ghc-options: { ghc-options: {
-Wall -Wall

93
src/Language/Haskell/Brittany.hs
View File

@ -15,34 +15,35 @@ where
#include "prelude.inc" #include "prelude.inc"
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess
import qualified Data.Generics as SYB import qualified Data.Generics as SYB
import qualified Data.Map as Map
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Debug.Trace as Trace
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.Config.Types import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import Language.Haskell.Brittany.Layouters.Type import Language.Haskell.Brittany.Layouters.Type
import Language.Haskell.Brittany.Layouters.Decl import Language.Haskell.Brittany.Layouters.Decl
import Language.Haskell.Brittany.Utils import Language.Haskell.Brittany.Utils
import Language.Haskell.Brittany.BriLayouter import Language.Haskell.Brittany.Backend
import Language.Haskell.Brittany.BackendUtils
import Language.Haskell.Brittany.ExactPrintUtils import Language.Haskell.Brittany.ExactPrintUtils
import Language.Haskell.Brittany.Transformations.Alt
import Language.Haskell.Brittany.Transformations.Floating
import Language.Haskell.Brittany.Transformations.Par
import Language.Haskell.Brittany.Transformations.Columns
import Language.Haskell.Brittany.Transformations.Indent
import qualified GHC as GHC hiding (parseModule) import qualified GHC as GHC hiding (parseModule)
import ApiAnnotation ( AnnKeywordId(..) ) import ApiAnnotation ( AnnKeywordId(..) )
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import qualified SrcLoc as GHC
import HsSyn import HsSyn
import Data.HList.HList import Data.HList.HList
@ -249,3 +250,77 @@ _bindHead = \case
FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _pat _ _ _ ([], []) -> "PatBind smth" PatBind _pat _ _ _ ([], []) -> "PatBind smth"
_ -> "unknown bind" _ -> "unknown bind"
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
layoutBriDoc ast briDoc = do
-- first step: transform the briDoc.
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
$ briDocToDoc
$ unwrapBriDocNumbered
$ briDoc
-- bridoc transformation: remove alts
transformAlts briDoc >>= mSet
mGet
>>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
. briDocToDoc
-- bridoc transformation: float stuff in
mGet <&> transformSimplifyFloating >>= mSet
mGet
>>= traceIfDumpConf "bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
. briDocToDoc
-- bridoc transformation: par removal
mGet <&> transformSimplifyPar >>= mSet
mGet
>>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
. briDocToDoc
-- bridoc transformation: float stuff in
mGet <&> transformSimplifyColumns >>= mSet
mGet
>>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
. briDocToDoc
-- -- bridoc transformation: indent
mGet <&> transformSimplifyIndent >>= mSet
mGet
>>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
. briDocToDoc
mGet
>>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
. briDocToDoc
-- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple
-- return simpl
anns :: ExactPrint.Types.Anns <- mAsk
let filteredAnns = filterAnns ast anns
traceIfDumpConf "bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns
let state = LayoutState
{ _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we use left here
-- because moveToAnn stuff of the
-- first node needs to do its
-- thing properly.
, _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0
, _lstate_comments = filteredAnns
, _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
}
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let
remainingComments =
extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments
`forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
return $ ()

471
src/Language/Haskell/Brittany/Backend.hs Normal file
View File

@ -0,0 +1,471 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
module Language.Haskell.Brittany.Backend
( layoutBriDocM
)
where
#include "prelude.inc"
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )
import Language.Haskell.Brittany.LayouterBasics
import Language.Haskell.Brittany.BackendUtils
import Language.Haskell.Brittany.Utils
import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
import Data.HList.ContainsType
import Control.Monad.Extra ( whenM )
import qualified Control.Monad.Trans.Writer.Strict as WriterS
briDocLineLength :: BriDoc -> Int
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- the state encodes whether a separate was already
-- appended at the current position.
where
rec = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDLines ls@(_:_) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDProhibitMTEL bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd
layoutBriDocM
:: forall w m
. ( m ~ MultiRWSS.MultiRWST
'[Config, ExactPrint.Anns]
w
'[LayoutState]
Identity
, ContainsType Text.Builder.Builder w
, ContainsType [LayoutError] w
, ContainsType (Seq String) w
)
=> BriDoc
-> m ()
layoutBriDocM = \case
BDEmpty -> do
return () -- can it be that simple
BDLit t -> do
layoutIndentRestorePostComment
layoutRemoveIndentLevelLinger
layoutWriteAppend t
BDSeq list -> do
list `forM_` layoutBriDocM
-- in this situation, there is nothing to do about cols.
-- i think this one does not happen anymore with the current simplifications.
-- BDCols cSig list | BDPar sameLine lines <- List.last list ->
-- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
BDCols _ list -> do
list `forM_` layoutBriDocM
BDSeparator -> do
layoutAddSepSpace
BDAddBaseY indent bd -> do
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do
layoutBaseYPushCur
layoutBriDocM bd
BDBaseYPop bd -> do
layoutBriDocM bd
layoutBaseYPop
BDIndentLevelPushCur bd -> do
layoutIndentLevelPushCur
layoutBriDocM bd
BDIndentLevelPop bd -> do
layoutBriDocM bd
layoutIndentLevelPop
BDEnsureIndent indent bd -> do
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteEnsureBlock
layoutBriDocM bd
BDPar indent sameLine indented -> do
layoutBriDocM sameLine
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteNewlineBlock
layoutBriDocM indented
BDLines lines ->
alignColsLines lines
BDAlt [] -> error "empty BDAlt"
BDAlt (alt:_) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do
layoutWriteAppend $ Text.pack $ "{-" ++ show (annKey, Map.lookup annKey anns) ++ "-}"
zip [1..] tlines `forM_` \(i, l) -> do
layoutWriteAppend $ l
unless (i==tlineCount) layoutWriteNewlineBlock
do
state <- mGet
let filterF k _ = not $ k `Set.member` subKeys
mSet $ state
{ _lstate_comments = Map.filterWithKey filterF
$ _lstate_comments state
}
BDAnnotationPrior annKey bd -> do
state <- mGet
let m = _lstate_comments state
let allowMTEL = not (_lstate_inhibitMTEL state)
&& Data.Either.isRight (_lstate_curYOrAddNewline state)
mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) annKey m
}
return mAnn
case mAnn of
Nothing -> when allowMTEL $ moveToExactAnn annKey
Just [] -> when allowMTEL $ moveToExactAnn annKey
Just priors -> do
-- layoutResetSepSpace
priors `forM_` \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (y, x)
) -> do
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
when allowMTEL $ moveToExactAnn annKey
layoutBriDocM bd
BDAnnotationKW annKey keyword bd -> do
layoutBriDocM bd
mAnn <- do
state <- mGet
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of
Just anns | keyword==Nothing -> Just anns
Just ((ExactPrint.Types.G kw1, _):annR)
| keyword==Just kw1 -> Just annR
_ -> Nothing
case mToSpan of
Just anns -> do
let (comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annsDP = rest })
annKey
m
}
return $ [ comments | not $ null comments ]
_ -> return Nothing
forM_ mAnn $ mapM_ $ \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (y, x)
) -> do
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do
layoutBriDocM bd
mAnn <- do
state <- mGet
let m = _lstate_comments state
let mAnn = extractAllComments <$> Map.lookup annKey m
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = []
, ExactPrint.annsDP = []
}
)
annKey
m
}
return mAnn
forM_ mAnn $ mapM_ $ \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (y, x)
) -> do
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDNonBottomSpacing bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd
BDProhibitMTEL bd -> do
-- set flag to True for this child, but disable afterwards.
-- two hard aspects
-- 1) nesting should be allowed. this means that resetting at the end must
-- not indiscriminantely set to False, but take into account the
-- previous value
-- 2) nonetheless, newlines cancel inhibition. this means that if we ever
-- find the flag set to False afterwards, we must not return it to
-- the previous value, which might be True in the case of testing; it
-- must remain False.
state <- mGet
mSet $ state { _lstate_inhibitMTEL = True }
layoutBriDocM bd
state' <- mGet
when (_lstate_inhibitMTEL state') $ do
mSet $ state' { _lstate_inhibitMTEL = _lstate_inhibitMTEL state }
BDDebug s bd -> do
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd
where
-- alignColsPar :: [BriDoc]
-- -> m ()
-- alignColsPar l = colInfos `forM_` \colInfo -> do
-- layoutWriteNewlineBlock
-- processInfo (_cbs_map finalState) colInfo
-- where
-- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)
alignColsLines :: [BriDoc]
-> m ()
alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
curX <- do
state <- mGet
return $ either id (const 0) (_lstate_curYOrAddNewline state)
+ fromMaybe 0 (_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos <&> processInfo (processedMap curX colMax)
where
(colInfos, finalState) = StateS.runState (mergeBriDocs bridocs)
(ColBuildState IntMapS.empty 0)
maxZipper :: [Int] -> [Int] -> [Int]
maxZipper [] ys = ys
maxZipper xs [] = xs
maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
processedMap :: Int -> Int -> ColMap2
processedMap curX colMax = fix $ \result ->
_cbs_map finalState <&> \colSpacingss ->
let colss = colSpacingss <&> \spss -> case reverse spss of
[] -> []
(xN:xR) -> reverse $ fLast xN : fmap fInit xR
where
fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = Foldable.foldl1 maxZipper colss
(_, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols
counter count l =
if List.last posXs + List.last l <=colMax
then count + 1
else count
ratio = fromIntegral (foldl counter (0::Int) colss)
/ fromIntegral (length colss)
in (ratio, maxCols, colss)
briDocToColInfo :: BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo = \case
BDCols sig list -> withAlloc $ \ind -> do
subInfos <- mapM briDocToColInfo list
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do
info <- mergeInfoBriDoc lastInfo bd
infor <- mergeBriDocsW info bdr
return $ info : infor
mergeInfoBriDoc :: ColInfo
-> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc ColInfoStart = briDocToColInfo
mergeInfoBriDoc ColInfoNo{} = briDocToColInfo
mergeInfoBriDoc (ColInfo infoInd infoSig subLengthsInfos) = \case
bd@(BDCols colSig subDocs)
| infoSig == colSig
&& length subLengthsInfos == length subDocs -> do
infos <- zip (snd <$> subLengthsInfos) subDocs
`forM` uncurry mergeInfoBriDoc
let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map
s <- StateS.get
let m = _cbs_map s
let (Just spaces) = IntMapS.lookup infoInd m
StateS.put s
{ _cbs_map = IntMapS.insert infoInd
(spaces Seq.|> trueSpacings)
m
}
return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise -> briDocToColInfo bd
bd -> return $ ColInfoNo bd
withAlloc :: (ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> StateS.State ColBuildState ColInfo
withAlloc f = do
cbs <- StateS.get
let ind = _cbs_index cbs
StateS.put $ cbs { _cbs_index = ind + 1 }
(space, info) <- f ind
StateS.get >>= \c -> StateS.put
$ c { _cbs_map = IntMapS.insert ind space $ _cbs_map c }
return info
processInfo :: ColMap2 -> ColInfo -> m ()
processInfo m = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo ind _ list -> do
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do
state <- mGet
return $ either id (const 0) (_lstate_curYOrAddNewline state)
+ fromMaybe 0 (_lstate_addSepSpace state)
-- tellDebugMess $ show curX
let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m
let (maxX, posXs) = mapAccumL (\acc x -> (acc+x,acc)) curX maxCols
-- handle the cases that the vertical alignment leads to more than max
-- cols:
-- this is not a full fix, and we must correct individually in addition.
-- because: the (at least) line with the largest element in the last
-- column will always still overflow, because we just updated the column
-- sizes in such a way that it works _if_ we have sizes (*factor)
-- in each column. but in that line, in the last column, we will be
-- forced to occupy the full vertical space, not reduced by any factor.
let fixedPosXs = case alignMode of
ColumnAlignModeAnimouslyScale i | maxX>colMax -> fixed <&> (+curX)
where
factor :: Float =
-- 0.0001 as an offering to the floating point gods.
min 1.0001 ( fromIntegral (i + colMax - curX)
/ fromIntegral (maxX - curX)
)
offsets = (subtract curX) <$> posXs
fixed = offsets <&> fromIntegral .> (*factor) .> truncate
_ -> posXs
let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do
layoutWriteEnsureAbsoluteN destX
processInfo m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore)
animousAct =
-- per-item check if there is overflowing.
if List.last fixedPosXs + fst (List.last list) > colMax
then noAlignAct
else alignAct
case alignMode of
ColumnAlignModeDisabled -> noAlignAct
ColumnAlignModeUnanimously | maxX<=colMax -> alignAct
ColumnAlignModeUnanimously -> noAlignAct
ColumnAlignModeMajority limit | ratio>=limit -> animousAct
ColumnAlignModeMajority{} -> noAlignAct
ColumnAlignModeAnimouslyScale{} -> animousAct
ColumnAlignModeAnimously -> animousAct
ColumnAlignModeAlways -> alignAct
processInfoIgnore :: ColInfo -> m ()
processInfoIgnore = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
type ColIndex = Int
data ColumnSpacing
= ColumnSpacingLeaf Int
| ColumnSpacingRef Int Int
type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (ColumnBlocks ColumnSpacing)
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw)
data ColInfo
= ColInfoStart -- start value to begin the mapAccumL.
| ColInfoNo BriDoc
| ColInfo ColIndex ColSig [(Int, ColInfo)]
instance Show ColInfo where
show ColInfoStart = "ColInfoStart"
show ColInfoNo{} = "ColInfoNo{}"
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1
, _cbs_index :: ColIndex
}

606
src/Language/Haskell/Brittany/BackendUtils.hs Normal file
View File

@ -0,0 +1,606 @@
#define INSERTTRACES 0
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeApplications #-}
#if !INSERTTRACES
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
module Language.Haskell.Brittany.BackendUtils
( layoutWriteAppend
, layoutWriteAppendMultiline
, layoutWriteNewlineBlock
, layoutWriteNewline
, layoutWriteEnsureNewlineBlock
, layoutWriteEnsureBlock
, layoutWithAddBaseCol
, layoutWithAddBaseColBlock
, layoutWithAddBaseColN
, layoutWithAddBaseColNBlock
, layoutBaseYPushCur
, layoutBaseYPop
, layoutIndentLevelPushCur
, layoutIndentLevelPop
, layoutWriteEnsureAbsoluteN
, layoutAddSepSpace
, layoutSetCommentCol
, layoutMoveToCommentPos
, layoutIndentRestorePostComment
, moveToExactAnn
, ppmMoveToExactLoc
, layoutWritePriorComments
, layoutWritePostComments
, layoutRemoveIndentLevelLinger
)
where
#include "prelude.inc"
import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.Config.Types
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey
, Annotation
, KeywordId
)
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Utils
import GHC ( GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan )
traceLocal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a)
=> a
-> m ()
#if INSERTTRACES
traceLocal x = do
mGet >>= tellDebugMessShow @LayoutState
tellDebugMessShow x
#else
traceLocal _ = return ()
#endif
layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppend t = do
traceLocal ("layoutWriteAppend", t)
state <- mGet
case _lstate_curYOrAddNewline state of
Right i -> do
#if INSERTTRACES
tellDebugMessShow (" inserted newlines: ", i)
#endif
replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"
Left{} -> do
#if INSERTTRACES
tellDebugMessShow (" inserted no newlines")
#endif
return ()
let spaces = case _lstate_addSepSpace state of
Just i -> i
Nothing -> 0
#if INSERTTRACES
tellDebugMessShow (" inserted spaces: ", spaces)
#endif
mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ')
mTell $ Text.Builder.fromText $ t
mModify $ \s -> s
{ _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of
Left c -> c + Text.length t + spaces
Right{} -> Text.length t + spaces
, _lstate_addSepSpace = Nothing
}
layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteAppendSpaces i = do
traceLocal ("layoutWriteAppendSpaces", i)
unless (i == 0) $ do
state <- mGet
mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
}
layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppendMultiline t = do
traceLocal ("layoutWriteAppendMultiline", t)
case Text.lines t of
[] -> layoutWriteAppend t -- need to write empty, too.
(l:lr) -> do
layoutWriteAppend l
lr `forM_` \x -> do
layoutWriteNewline
layoutWriteAppend x
-- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock")
state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
}
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m) => Int -> m ()
-- layoutMoveToIndentCol i = do
-- #if INSERTTRACES
-- tellDebugMessShow ("layoutMoveToIndentCol", i)
-- #endif
-- state <- mGet
-- mSet $ state
-- { _lstate_addSepSpace = Just
-- $ if isJust $ _lstate_addNewline state
-- then i
-- else _lstate_indLevelLinger state + i - _lstate_curY state
-- }
layoutSetCommentCol
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutSetCommentCol = do
state <- mGet
let col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state)
$ mSet state { _lstate_commentCol = Just col }
layoutMoveToCommentPos
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> Int
-> m ()
layoutMoveToCommentPos y x = do
traceLocal ("layoutMoveToCommentPos", y, x)
state <- mGet
if Data.Maybe.isJust (_lstate_commentCol state)
then do
mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right{} -> Right y
, _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x
}
else do
mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right{} -> Right y
, _lstate_addSepSpace = Just
$ if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
}
-- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewline = do
traceLocal ("layoutWriteNewline")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
}
layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
, _lstate_commentCol = Nothing
}
layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteEnsureAbsoluteN n = do
state <- mGet
let diff = case _lstate_curYOrAddNewline state of
Left i -> n - i
Right{} -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff > 0) $ do
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, MonadMultiWriter (Seq String) m)
=> Int
-> m ()
layoutBaseYPushInternal i = do
traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutBaseYPopInternal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutBaseYPopInternal = do
traceLocal ("layoutBaseYPopInternal")
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
layoutIndentLevelPushInternal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m)
=> Int
-> m ()
layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s
}
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
) => m ()
layoutRemoveIndentLevelLinger = do
#if INSERTTRACES
tellDebugMessShow ("layoutRemoveIndentLevelLinger")
#endif
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
}
layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader Config m
, MonadMultiWriter (Seq String) m
)
=> m ()
-> m ()
layoutWithAddBaseCol m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseCol")
#endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
m
layoutBaseYPopInternal
layoutWithAddBaseColBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader Config m
, MonadMultiWriter (Seq String) m
)
=> m ()
-> m ()
layoutWithAddBaseColBlock m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseColBlock")
#endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
layoutWriteEnsureBlock
m
layoutBaseYPopInternal
layoutWithAddBaseColNBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
-> m ()
layoutWithAddBaseColNBlock amount m = do
traceLocal ("layoutWithAddBaseColNBlock", amount)
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
layoutWriteEnsureBlock
m
layoutBaseYPopInternal
layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock")
state <- mGet
let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
(Nothing, Left i ) -> lstate_baseY state - i
(Nothing, Right{}) -> lstate_baseY state
(Just sp, Left i ) -> max sp (lstate_baseY state - i)
(Just sp, Right{}) -> max sp (lstate_baseY state)
-- when (diff>0) $ layoutWriteNewlineBlock
when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
-> m ()
layoutWithAddBaseColN amount m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseColN", amount)
#endif
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
m
layoutBaseYPopInternal
layoutBaseYPushCur
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur")
state <- mGet
case _lstate_commentCol state of
Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutBaseYPop = do
traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal
layoutIndentLevelPushCur
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur")
state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> i + j
(Left i , Nothing) -> i
(Right{}, Just j ) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y
layoutBaseYPushInternal y
layoutIndentLevelPop
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop")
layoutBaseYPopInternal
layoutIndentLevelPopInternal
-- why are comment indentations relative to the previous indentation on
-- the first node of an additional indentation, and relative to the outer
-- indentation after the last node of some indented stuff? sure does not
-- make sense.
layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> m ()
layoutAddSepSpace = do
#if INSERTTRACES
tellDebugMessShow ("layoutAddSepSpace")
#endif
state <- mGet
mSet $ state
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }
-- TODO: when refactoring is complete, the other version of this method
-- can probably be removed.
moveToExactAnn
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader (Map AnnKey Annotation) m
, MonadMultiWriter (Seq String) m
)
=> AnnKey
-> m ()
moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey)
anns <- mAsk
case Map.lookup annKey anns of
Nothing -> return ()
Just ann -> do
-- curY <- mGet <&> _lstate_curY
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
-- mModify $ \state -> state { _lstate_addNewline = Just x }
mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then
_lstate_commentCol state
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
-- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do
-- newLineState <- mGet <&> _lstate_isNewline
-- return $ if newLineState == NewLineStateYes
-- then x-1
-- else x
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " "
layoutWritePriorComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> GenLocated SrcSpan ast
-> m ()
layoutWritePriorComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns
}
return mAnn
#if INSERTTRACES
tellDebugMessShow ("layoutWritePriorComments", ExactPrint.mkAnnKey ast, mAnn)
#endif
case mAnn of
Nothing -> return ()
Just priors -> do
when (not $ null priors) $ layoutSetCommentCol
priors `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y)
) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.pack $ comment
-- 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
, MonadMultiWriter (Seq String) m)
=> GenLocated SrcSpan ast -> m ()
layoutWritePostComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })
key
anns
}
return mAnn
#if INSERTTRACES
tellDebugMessShow ("layoutWritePostComments", ExactPrint.mkAnnKey ast, mAnn)
#endif
case mAnn of
Nothing -> return ()
Just posts -> do
when (not $ null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y)
) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' '
layoutWriteAppendMultiline $ Text.pack $ comment
layoutIndentRestorePostComment
:: ( MonadMultiState LayoutState m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutIndentRestorePostComment = do
state <- mGet
let mCommentCol = _lstate_commentCol state
let eCurYAddNL = _lstate_curYOrAddNewline state
#if INSERTTRACES
tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol)
#endif
mModify $ \s -> s { _lstate_commentCol = Nothing }
case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)
_ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m,
-- MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m)
-- => GenLocated SrcSpan ast -> m ()
-- layoutWritePriorCommentsRestore x = do
-- layoutWritePriorComments x
-- layoutIndentRestorePostComment
--
-- layoutWritePostCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m,
-- MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m)
-- => GenLocated SrcSpan ast -> m ()
-- layoutWritePostCommentsRestore x = do
-- layoutWritePostComments x
-- layoutIndentRestorePostComment

1730
src/Language/Haskell/Brittany/BriLayouter.hs
View File

File diff suppressed because it is too large Load Diff

40
src/Language/Haskell/Brittany/Config.hs
View File

@ -16,46 +16,8 @@ where
#include "prelude.inc" #include "prelude.inc"
import DynFlags ( getDynFlags )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import qualified Parser as GHC
import qualified ApiAnnotation as GHC
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified GHC as GHC hiding (parseModule)
import qualified HeaderInfo as GHC
import qualified Lexer as GHC
import qualified MonadUtils as GHC
import qualified Outputable as GHC
import qualified Parser as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
import RdrName ( RdrName(..) )
import Control.Monad.IO.Class
import GHC.Paths (libdir)
import HsSyn
import SrcLoc ( SrcSpan, Located )
-- import Outputable ( ppr, runSDoc )
-- import DynFlags ( unsafeGlobalDynFlags )
import ApiAnnotation ( AnnKeywordId(..) )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess
import qualified Data.Map as Map
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Debug.Trace as Trace
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
-- import Data.Aeson
import GHC.Generics
import Control.Lens
import qualified Data.Yaml import qualified Data.Yaml

32
src/Language/Haskell/Brittany/ExactPrintUtils.hs
View File

@ -12,31 +12,22 @@ where
#include "prelude.inc" #include "prelude.inc"
import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.LayouterBasics
import Language.Haskell.Brittany.Utils
import DynFlags ( getDynFlags ) import DynFlags ( getDynFlags )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import qualified Parser as GHC
import qualified ApiAnnotation as GHC
import qualified DynFlags as GHC import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified GHC as GHC hiding (parseModule) import qualified GHC as GHC hiding (parseModule)
import qualified HeaderInfo as GHC
import qualified Lexer as GHC
import qualified MonadUtils as GHC
import qualified Outputable as GHC
import qualified Parser as GHC import qualified Parser as GHC
import qualified SrcLoc as GHC import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import Control.Monad.IO.Class
import HsSyn import HsSyn
import SrcLoc ( SrcSpan, Located ) import SrcLoc ( SrcSpan, Located )
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import Name
import qualified FastString
import BasicTypes
import ApiAnnotation ( AnnKeywordId(..) )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
@ -46,19 +37,6 @@ import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
import qualified Data.Generics as SYB import qualified Data.Generics as SYB
import qualified Data.Map as Map
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Debug.Trace as Trace
import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.LayoutBasics
import Language.Haskell.Brittany.Utils
import DataTreePrint
parseModule parseModule

592
src/Language/Haskell/Brittany/LayoutBasics.hs → src/Language/Haskell/Brittany/LayouterBasics.hs
View File

@ -1,45 +1,12 @@
#define INSERTTRACES 0 module Language.Haskell.Brittany.LayouterBasics
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeApplications #-}
#if !INSERTTRACES
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
module Language.Haskell.Brittany.LayoutBasics
( processDefault ( processDefault
, rdrNameToText , rdrNameToText
, lrdrNameToText , lrdrNameToText
, lrdrNameToTextAnn , lrdrNameToTextAnn
, lrdrNameToTextAnnTypeEqualityIsSpecial , lrdrNameToTextAnnTypeEqualityIsSpecial
, askIndent , askIndent
, layoutWriteAppend
, layoutWriteAppendMultiline
, layoutWriteNewlineBlock
, layoutWriteNewline
, layoutWriteEnsureNewlineBlock
, layoutWriteEnsureBlock
, layoutWithAddBaseCol
, layoutWithAddBaseColBlock
, layoutWithAddBaseColN
, layoutWithAddBaseColNBlock
, layoutBaseYPushCur
, layoutBaseYPop
, layoutIndentLevelPushCur
, layoutIndentLevelPop
, layoutWriteEnsureAbsoluteN
, layoutAddSepSpace
, layoutSetCommentCol
, layoutMoveToCommentPos
, layoutIndentRestorePostComment
, moveToExactAnn
, layoutWritePriorComments
, layoutWritePostComments
, layoutRemoveIndentLevelLinger
, extractAllComments , extractAllComments
, filterAnns , filterAnns
, ppmMoveToExactLoc
, docEmpty , docEmpty
, docLit , docLit
, docAlt , docAlt
@ -102,9 +69,6 @@ import Language.Haskell.Brittany.Utils
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import qualified Outputable as GHC
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified SrcLoc as GHC import qualified SrcLoc as GHC
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import OccName ( occNameString ) import OccName ( occNameString )
@ -114,26 +78,10 @@ import ApiAnnotation ( AnnKeywordId(..) )
import Data.Data import Data.Data
import Data.Generics.Schemes import Data.Generics.Schemes
import Data.Generics.Aliases
import DataTreePrint import DataTreePrint
import qualified Text.PrettyPrint as PP
import Data.Function ( fix )
traceLocal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a)
=> a
-> m ()
#if INSERTTRACES
traceLocal x = do
mGet >>= tellDebugMessShow @LayoutState
tellDebugMessShow x
#else
traceLocal _ = return ()
#endif
processDefault processDefault
:: ( ExactPrint.Annotate.Annotate ast :: ( ExactPrint.Annotate.Annotate ast
@ -228,543 +176,6 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
askIndent :: (MonadMultiReader Config m) => m Int askIndent :: (MonadMultiReader Config m) => m Int
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppend t = do
traceLocal ("layoutWriteAppend", t)
state <- mGet
case _lstate_curYOrAddNewline state of
Right i -> do
#if INSERTTRACES
tellDebugMessShow (" inserted newlines: ", i)
#endif
replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"
Left{} -> do
#if INSERTTRACES
tellDebugMessShow (" inserted no newlines")
#endif
return ()
let spaces = case _lstate_addSepSpace state of
Just i -> i
Nothing -> 0
#if INSERTTRACES
tellDebugMessShow (" inserted spaces: ", spaces)
#endif
mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ')
mTell $ Text.Builder.fromText $ t
mModify $ \s -> s
{ _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of
Left c -> c + Text.length t + spaces
Right{} -> Text.length t + spaces
, _lstate_addSepSpace = Nothing
}
layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteAppendSpaces i = do
traceLocal ("layoutWriteAppendSpaces", i)
unless (i == 0) $ do
state <- mGet
mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
}
layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppendMultiline t = do
traceLocal ("layoutWriteAppendMultiline", t)
case Text.lines t of
[] -> layoutWriteAppend t -- need to write empty, too.
(l:lr) -> do
layoutWriteAppend l
lr `forM_` \x -> do
layoutWriteNewline
layoutWriteAppend x
-- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock")
state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
}
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m) => Int -> m ()
-- layoutMoveToIndentCol i = do
-- #if INSERTTRACES
-- tellDebugMessShow ("layoutMoveToIndentCol", i)
-- #endif
-- state <- mGet
-- mSet $ state
-- { _lstate_addSepSpace = Just
-- $ if isJust $ _lstate_addNewline state
-- then i
-- else _lstate_indLevelLinger state + i - _lstate_curY state
-- }
layoutSetCommentCol
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutSetCommentCol = do
state <- mGet
let col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state)
$ mSet state { _lstate_commentCol = Just col }
layoutMoveToCommentPos
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> Int
-> m ()
layoutMoveToCommentPos y x = do
traceLocal ("layoutMoveToCommentPos", y, x)
state <- mGet
if Data.Maybe.isJust (_lstate_commentCol state)
then do
mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right{} -> Right y
, _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x
}
else do
mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right{} -> Right y
, _lstate_addSepSpace = Just
$ if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
}
-- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewline = do
traceLocal ("layoutWriteNewline")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
}
layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
, _lstate_commentCol = Nothing
}
layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock")
state <- mGet
let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
(Nothing, Left i ) -> lstate_baseY state - i
(Nothing, Right{}) -> lstate_baseY state
(Just sp, Left i ) -> max sp (lstate_baseY state - i)
(Just sp, Right{}) -> max sp (lstate_baseY state)
-- when (diff>0) $ layoutWriteNewlineBlock
when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteEnsureAbsoluteN n = do
state <- mGet
let diff = case _lstate_curYOrAddNewline state of
Left i -> n - i
Right{} -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff > 0) $ do
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, MonadMultiWriter (Seq String) m)
=> Int
-> m ()
layoutBaseYPushInternal i = do
traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutBaseYPopInternal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutBaseYPopInternal = do
traceLocal ("layoutBaseYPopInternal")
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
layoutIndentLevelPushInternal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m)
=> Int
-> m ()
layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s
}
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
) => m ()
layoutRemoveIndentLevelLinger = do
#if INSERTTRACES
tellDebugMessShow ("layoutRemoveIndentLevelLinger")
#endif
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
}
layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader Config m
, MonadMultiWriter (Seq String) m
)
=> m ()
-> m ()
layoutWithAddBaseCol m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseCol")
#endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
m
layoutBaseYPopInternal
layoutWithAddBaseColBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader Config m
, MonadMultiWriter (Seq String) m
)
=> m ()
-> m ()
layoutWithAddBaseColBlock m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseColBlock")
#endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
layoutWriteEnsureBlock
m
layoutBaseYPopInternal
layoutWithAddBaseColNBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
-> m ()
layoutWithAddBaseColNBlock amount m = do
traceLocal ("layoutWithAddBaseColNBlock", amount)
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
layoutWriteEnsureBlock
m
layoutBaseYPopInternal
layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
-> m ()
layoutWithAddBaseColN amount m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseColN", amount)
#endif
state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount
m
layoutBaseYPopInternal
layoutBaseYPushCur
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur")
state <- mGet
case _lstate_commentCol state of
Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutBaseYPop = do
traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal
layoutIndentLevelPushCur
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur")
state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> i + j
(Left i , Nothing) -> i
(Right{}, Just j ) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y
layoutBaseYPushInternal y
layoutIndentLevelPop
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop")
layoutBaseYPopInternal
layoutIndentLevelPopInternal
-- why are comment indentations relative to the previous indentation on
-- the first node of an additional indentation, and relative to the outer
-- indentation after the last node of some indented stuff? sure does not
-- make sense.
layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> m ()
layoutAddSepSpace = do
#if INSERTTRACES
tellDebugMessShow ("layoutAddSepSpace")
#endif
state <- mGet
mSet $ state
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }
-- TODO: when refactoring is complete, the other version of this method
-- can probably be removed.
moveToExactAnn
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader (Map AnnKey Annotation) m
, MonadMultiWriter (Seq String) m
)
=> AnnKey
-> m ()
moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey)
anns <- mAsk
case Map.lookup annKey anns of
Nothing -> return ()
Just ann -> do
-- curY <- mGet <&> _lstate_curY
let ExactPrint.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann
-- mModify $ \state -> state { _lstate_addNewline = Just x }
mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then
_lstate_commentCol state
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
-- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do
-- newLineState <- mGet <&> _lstate_isNewline
-- return $ if newLineState == NewLineStateYes
-- then x-1
-- else x
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.Types.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " "
layoutWritePriorComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> GenLocated SrcSpan ast
-> m ()
layoutWritePriorComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.Types.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns
}
return mAnn
#if INSERTTRACES
tellDebugMessShow ("layoutWritePriorComments", ExactPrint.Types.mkAnnKey ast, mAnn)
#endif
case mAnn of
Nothing -> return ()
Just priors -> do
when (not $ null priors) $ layoutSetCommentCol
priors `forM_` \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (x, y)
) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.pack $ comment
-- 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
, MonadMultiWriter (Seq String) m)
=> GenLocated SrcSpan ast -> m ()
layoutWritePostComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.Types.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })
key
anns
}
return mAnn
#if INSERTTRACES
tellDebugMessShow ("layoutWritePostComments", ExactPrint.Types.mkAnnKey ast, mAnn)
#endif
case mAnn of
Nothing -> return ()
Just posts -> do
when (not $ null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (x, y)
) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' '
layoutWriteAppendMultiline $ Text.pack $ comment
layoutIndentRestorePostComment
:: ( MonadMultiState LayoutState m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutIndentRestorePostComment = do
state <- mGet
let mCommentCol = _lstate_commentCol state
let eCurYAddNL = _lstate_curYOrAddNewline state
#if INSERTTRACES
tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol)
#endif
mModify $ \s -> s { _lstate_commentCol = Nothing }
case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)
_ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m,
-- MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m)
-- => GenLocated SrcSpan ast -> m ()
-- layoutWritePriorCommentsRestore x = do
-- layoutWritePriorComments x
-- layoutIndentRestorePostComment
--
-- layoutWritePostCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m,
-- MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m)
-- => GenLocated SrcSpan ast -> m ()
-- layoutWritePostCommentsRestore x = do
-- layoutWritePostComments x
-- layoutIndentRestorePostComment
extractAllComments extractAllComments
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
@ -776,7 +187,6 @@ extractAllComments ann =
_ -> [] _ -> []
) )
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = everything foldedAnnKeys ast = everything
Set.union Set.union

2
src/Language/Haskell/Brittany/Layouters/Decl.hs
View File

@ -17,7 +17,7 @@ where
#include "prelude.inc" #include "prelude.inc"
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import Language.Haskell.Brittany.Config.Types import Language.Haskell.Brittany.Config.Types
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )

2
src/Language/Haskell/Brittany/Layouters/Expr.hs
View File

@ -12,7 +12,7 @@ where
#include "prelude.inc" #include "prelude.inc"
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )

2
src/Language/Haskell/Brittany/Layouters/Expr.hs-boot
View File

@ -12,7 +12,7 @@ where
#include "prelude.inc" #include "prelude.inc"
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )

2
src/Language/Haskell/Brittany/Layouters/Pattern.hs
View File

@ -11,7 +11,7 @@ where
#include "prelude.inc" #include "prelude.inc"
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )

2
src/Language/Haskell/Brittany/Layouters/Stmt.hs
View File

@ -10,7 +10,7 @@ where
#include "prelude.inc" #include "prelude.inc"
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )

2
src/Language/Haskell/Brittany/Layouters/Stmt.hs-boot
View File

@ -10,7 +10,7 @@ where
#include "prelude.inc" #include "prelude.inc"
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )

2
src/Language/Haskell/Brittany/Layouters/Type.hs
View File

@ -11,7 +11,7 @@ where
import Language.Haskell.Brittany.Config.Types import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.Types import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayouterBasics
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )

792
src/Language/Haskell/Brittany/Transformations/Alt.hs Normal file
View File

@ -0,0 +1,792 @@
#define INSERTTRACESALT 0
#define INSERTTRACESGETSPACING 0
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
module Language.Haskell.Brittany.Transformations.Alt
( transformAlts
)
where
#include "prelude.inc"
import Data.HList.ContainsType
import Language.Haskell.Brittany.Utils
import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.Types
import qualified Control.Monad.Memo as Memo
data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line
, _acp_indent :: Int -- current indentation level
, _acp_indentPrep :: Int -- indentChange affecting the next Par
, _acp_forceMLFlag :: AltLineModeState
}
deriving (Show)
data AltLineModeState
= AltLineModeStateNone
| AltLineModeStateForceML Bool -- true ~ decays on next wrap
| AltLineModeStateForceSL
| AltLineModeStateContradiction
-- i.e. ForceX False -> ForceX True -> None
deriving (Show)
altLineModeRefresh :: AltLineModeState -> AltLineModeState
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction
altLineModeDecay :: AltLineModeState -> AltLineModeState
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True
altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos
mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of
(AltLineModeStateContradiction, _) -> acp
(AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }
(AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->
acp { _acp_forceMLFlag = s }
_ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }
-- removes any BDAlt's from the BriDoc
transformAlts
:: forall r w s
. ( Data.HList.ContainsType.ContainsType Config r
, Data.HList.ContainsType.ContainsType (Seq String) w
)
=> BriDocNumbered
-> MultiRWSS.MultiRWS r w s BriDoc
transformAlts briDoc =
MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)
$ Memo.startEvalMemoT
$ fmap unwrapBriDocNumbered
$ rec
$ briDoc
where
-- this funtion is exponential by nature and cannot be improved in any
-- way i can think of, and if tried. (stupid StableNames.)
-- transWrap :: BriDoc -> BriDocNumbered
-- transWrap brDc = flip StateS.evalState (1::Int)
-- $ Memo.startEvalMemoT
-- $ go brDc
-- where
-- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i
-- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered
-- go = Memo.memo $ \bdX -> do
-- i <- lift $ incGet
-- fmap (\bd' -> (i,bd')) $ case bdX of
-- BDEmpty -> return $ BDFEmpty
-- BDLit t -> return $ BDFLit t
-- BDSeq list -> BDFSeq <$> go `mapM` list
-- BDCols sig list -> BDFCols sig <$> go `mapM` list
-- BDSeparator -> return $ BDFSeparator
-- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd
-- BDSetBaseY bd -> BDFSetBaseY <$> go bd
-- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd
-- BDPar ind line indented -> [ BDFPar ind line' indented'
-- | line' <- go line
-- , indented' <- go indented
-- ]
-- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen
-- BDForceMultiline bd -> BDFForceMultiline <$> go bd
-- BDForceSingleline bd -> BDFForceSingleline <$> go bd
-- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd
-- BDExternal k ks c t -> return $ BDFExternal k ks c t
-- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd
-- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd
-- BDLines lines -> BDFLines <$> go `mapM` lines
-- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd
-- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered
rec bdX@(brDcId, brDc) = do
#if INSERTTRACESALT
do
acp :: AltCurPos <- mGet
tellDebugMess $ "transformAlts: visiting: " ++ case brDc of
BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp)
BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp)
_ -> show (toConstr brDc, acp)
#endif
let reWrap = (,) brDcId
-- debugAcp :: AltCurPos <- mGet
case brDc of
-- BDWrapAnnKey annKey bd -> do
-- acp <- mGet
-- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
-- 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
BDFSeparator -> processSpacingSimple bdX $> bdX
BDFAddBaseY indent bd -> do
acp <- mGet
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAdd = case indent of
BrIndentNone -> 0
BrIndentRegular -> indAmount
BrIndentSpecial i -> i
mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd }
r <- rec bd
acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of
BrIndentNone -> r
BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r
BDFBaseYPushCur bd -> do
acp <- mGet
mSet $ acp { _acp_indent = _acp_line acp }
r <- rec bd
return $ reWrap $ BDFBaseYPushCur r
BDFBaseYPop bd -> do
acp <- mGet
r <- rec bd
acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indentPrep acp }
return $ reWrap $ BDFBaseYPop r
BDFIndentLevelPushCur bd -> do
reWrap . BDFIndentLevelPushCur <$> rec bd
BDFIndentLevelPop bd -> do
reWrap . BDFIndentLevelPop <$> rec bd
BDFPar indent sameLine indented -> do
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
}
sameLine' <- rec sameLine
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
-- possibility, but i will prefer a
-- fail-early approach; BDEmpty does not
-- make sense semantically for Alt[].
BDFAlt alts -> do
altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
case altChooser of
AltChooserSimpleQuick -> do
rec $ head alts
AltChooserShallowBest -> do
spacings <- alts `forM` getSpacing
acp <- mGet
let lineCheck LineModeInvalid = False
lineCheck (LineModeValid (VerticalSpacing _ p _)) =
case _acp_forceMLFlag acp of
AltLineModeStateNone -> True
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False
lineCheck _ = error "ghc exhaustive check is insufficient"
lconf <- _conf_layout <$> mAsk
#if INSERTTRACESALT
tellDebugMess $ "considering options with " ++ show (length alts, acp)
#endif
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))
#if INSERTTRACESALT
zip spacings options `forM_` \(vs, (_, bd)) ->
tellDebugMess $ " " ++ "spacing=" ++ show vs
++ ",hasSpace=" ++ show (hasSpace1 lconf acp vs)
++ ",lineCheck=" ++ show (lineCheck vs)
++ " " ++ show (toConstr bd)
#endif
id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x)
$ rec
$ fromMaybe (-- trace ("choosing last") $
List.last alts)
$ 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
AltLineModeStateNone -> True
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False
lconf <- _conf_layout <$> mAsk
#if INSERTTRACESALT
tellDebugMess $ "considering options with " ++ show (length alts, acp)
#endif
let options = -- trace ("considering options:" ++ show (length alts, acp)) $
(zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( any (hasSpace2 lconf acp) vs
&& any lineCheck vs, bd))
let checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])
#if INSERTTRACESALT
zip spacings options `forM_` \(vs, (_, bd)) ->
tellDebugMess $ " " ++ "spacing=" ++ show vs
++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs)
++ ",lineCheck=" ++ show (lineCheck <$> vs)
++ " " ++ show (toConstr bd)
tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions)
#endif
id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x)
$ rec
$ fromMaybe (-- trace ("choosing last") $
List.last alts)
$ Data.List.Extra.firstJust (fmap snd) checkedOptions
BDFForceMultiline bd -> do
acp <- mGet
x <- do
mSet $ mergeLineMode acp (AltLineModeStateForceML False)
rec bd
acp' <- mGet
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
return $ x
BDFForceSingleline bd -> do
acp <- mGet
x <- do
mSet $ mergeLineMode acp AltLineModeStateForceSL
rec bd
acp' <- mGet
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
return $ x
BDFForwardLineMode bd -> do
acp <- mGet
x <- do
mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp }
rec bd
acp' <- mGet
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
return $ x
BDFExternal{} -> processSpacingSimple bdX $> bdX
BDFAnnotationPrior annKey bd -> do
acp <- mGet
mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
bd' <- rec bd
return $ reWrap $ BDFAnnotationPrior annKey bd'
BDFAnnotationRest annKey bd ->
reWrap . BDFAnnotationRest annKey <$> rec bd
BDFAnnotationKW annKey kw bd ->
reWrap . BDFAnnotationKW annKey kw <$> rec bd
BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.
BDFLines (l:lr) -> do
ind <- _acp_indent <$> mGet
l' <- rec l
lr' <- lr `forM` \x -> do
mModify $ \acp -> acp
{ _acp_line = ind
, _acp_indent = ind
}
rec x
return $ reWrap $ BDFLines (l':lr')
BDFEnsureIndent indent bd -> do
acp <- mGet
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAdd = case indent of
BrIndentNone -> 0
BrIndentRegular -> indAmount
BrIndentSpecial i -> i
mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid,
-- in general.
, _acp_indent = _acp_indent acp + indAdd
, _acp_line = _acp_line acp + indAdd
}
r <- rec bd
acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of
BrIndentNone -> 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
BDFProhibitMTEL bd ->
reWrap . BDFProhibitMTEL <$> rec bd
BDFDebug s bd -> do
acp :: AltCurPos <- mGet
tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp
reWrap . BDFDebug s <$> rec bd
processSpacingSimple :: (MonadMultiReader
Config m,
MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m ()
processSpacingSimple bd = getSpacing bd >>= \case
LineModeInvalid -> error "processSpacingSimple inv"
LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do
acp <- mGet
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 _ _ LineModeInvalid = False
hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs
hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"
hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool
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)
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
= line + sameLine <= confUnpack (_lconfig_cols lconf)
getSpacing
:: forall m
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> BriDocNumbered
-> m (LineModeValidity VerticalSpacing)
getSpacing !bridoc = rec bridoc
where
rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)
rec (brDcId, brDc) = do
config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack
result <- case brDc of
-- 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
BDFCols _sig list -> sumVs <$> rec `mapM` list
BDFSeparator ->
return $ LineModeValid $ 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
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j
}
BDFBaseYPushCur bd -> do
mVs <- rec bd
return $ mVs <&> \vs -> vs
-- We leave par as-is, even though it technically is not
-- accurate (in general).
-- 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)
(case _vs_paragraph vs of
VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i)
, _vs_paragraph = VerticalSpacingParAlways 0
}
BDFBaseYPop bd -> rec bd
BDFIndentLevelPushCur bd -> rec bd
BDFIndentLevelPop bd -> rec bd
BDFPar BrIndentNone sameLine indented -> do
mVs <- rec sameLine
mIndSp <- rec indented
return
$ [ VerticalSpacing lsp pspResult parFlagResult
| VerticalSpacing lsp mPsp _ <- mVs
, indSp <- mIndSp
, lineMax <- getMaxVS $ mIndSp
, 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
&& _vs_parFlag indSp
]
BDFPar{} -> error "BDPar with indent in getSpacing"
BDFAlt [] -> error "empty BDAlt"
BDFAlt (alt:_) -> rec alt
BDFForceMultiline bd -> rec bd
BDFForceSingleline bd -> do
mVs <- rec bd
return $ mVs >>= _vs_paragraph .> \case
VerticalSpacingParNone -> mVs
_ -> LineModeInvalid
BDFForwardLineMode bd -> rec bd
BDFExternal{} -> return
$ LineModeValid
$ VerticalSpacing 999 VerticalSpacingParNone False
BDFAnnotationPrior _annKey bd -> rec bd
BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFLines [] -> return
$ LineModeValid
$ VerticalSpacing 0 VerticalSpacingParNone False
BDFLines ls@(_:_) -> do
lSps@(mVs:_) <- rec `mapM` ls
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
BrIndentNone -> 0
BrIndentRegular -> confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp pf) ->
VerticalSpacing (lsp + addInd) psp pf
BDFNonBottomSpacing bd -> do
mVs <- rec bd
return
$ mVs
<|> LineModeValid (VerticalSpacing 0
(VerticalSpacingParAlways colMax)
False)
BDFSetParSpacing bd -> do
mVs <- rec bd
return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDFForceParSpacing bd -> do
mVs <- rec bd
return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]
BDFProhibitMTEL bd -> rec bd
BDFDebug s bd -> do
r <- rec bd
tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r
return r
#if INSERTTRACESGETSPACING
tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result
#endif
return result
maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
maxVs = foldl'
(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) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome j, VerticalSpacingParAlways i) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y) False))
(LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)
sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
sumVs sps = foldl' (liftM2 go) initial sps
where
go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing
(x1 + y1)
(case (x2, y2) of
(x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ x + y)
x3
singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone
singleline _ = False
isPar (LineModeValid x) = _vs_parFlag x
isPar _ = False
parFlag = case sps of
[] -> True
_ -> all singleline (List.init sps) && isPar (List.last sps)
initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag
getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int
getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of
VerticalSpacingParSome i -> i
VerticalSpacingParNone -> 0
VerticalSpacingParAlways i -> i
getSpacings
:: forall m
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> Int
-> BriDocNumbered
-> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
getSpacings limit bridoc = preFilterLimit <$> rec bridoc
where
preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]
preFilterLimit = take (3*limit)
memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v
memoWithKey k v = Memo.memo (const v) k
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
rec (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
VerticalSpacingParNone -> True
VerticalSpacingParSome i -> i <= colMax
VerticalSpacingParAlways{} -> True
let filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing]
filterAndLimit = take limit
. filter hasOkColCount
. preFilterLimit -- we need to limit here in case
-- that the input list is
-- _large_ with a similarly _large_
-- prefix not passing hasOkColCount
-- predicate.
-- TODO: 3 is arbitrary.
result <- case brdc of
-- BDWrapAnnKey _annKey bd -> rec bd
BDFEmpty ->
return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLit t ->
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFSeq list ->
fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list
BDFCols _sig list ->
fmap sumVs . sequence . fmap 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
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
)
BrIndentSpecial j -> i + j
}
BDFBaseYPushCur bd -> do
mVs <- rec bd
return $ mVs <&> \vs -> vs
-- We leave par as-is, even though it technically is not
-- accurate (in general).
-- 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)
(case _vs_paragraph vs of
VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i)
, _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParSome i -> VerticalSpacingParAlways i -- TODO: is this correct?
VerticalSpacingParAlways i -> VerticalSpacingParAlways i
}
BDFBaseYPop bd -> rec bd
BDFIndentLevelPushCur bd -> rec bd
BDFIndentLevelPop bd -> rec bd
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) ->
VerticalSpacing
lsp
(case mPsp of
VerticalSpacingParSome psp ->
VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO
VerticalSpacingParNone -> spMakePar indSp
VerticalSpacingParAlways psp ->
VerticalSpacingParAlways $ max psp $ getMaxVS indSp)
( mPsp == VerticalSpacingParNone
&& _vs_paragraph indSp == VerticalSpacingParNone
&& _vs_parFlag indSp
)
BDFPar{} -> error "BDPar with indent in getSpacing"
BDFAlt [] -> error "empty BDAlt"
-- BDAlt (alt:_) -> rec alt
BDFAlt alts -> do
r <- rec `mapM` alts
return $ filterAndLimit =<< r
BDFForceMultiline bd -> rec bd
BDFForceSingleline bd -> do
mVs <- filterAndLimit <$> rec bd
return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForwardLineMode bd -> rec bd
BDFExternal{} ->
return $ [] -- yes, we just assume that we cannot properly layout
-- this.
BDFAnnotationPrior _annKey bd -> rec bd
BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLines ls@(_:_) -> do
-- we simply assume that lines is only used "properly", i.e. in
-- such a way that the first line can be treated "as a part of the
-- paragraph". That most importantly means that Lines should never
-- be inserted anywhere but at the start of the line. A
-- counterexample would be anything like Seq[Lit "foo", Lines].
lSpss <- fmap filterAndLimit <$> rec `mapM` ls
let worbled = fmap reverse
$ sequence
$ reverse
$ lSpss
summed = worbled <&> \lSps@(lSp1:_) ->
VerticalSpacing (_vs_sameLine lSp1)
(spMakePar $ maxVs lSps)
False
return $ summed
-- lSpss@(mVs:_) <- rec `mapM` ls
-- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only
-- -- consider the first alternative for the
-- -- line's spacings.
-- -- also i am not sure if always including
-- -- the first line length in the paragraph
-- -- length gives the desired results.
-- -- it is the safe path though, for now.
-- [] -> []
-- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) ->
-- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps
BDFEnsureIndent indent bd -> do
mVs <- rec bd
let addInd = case indent of
BrIndentNone -> 0
BrIndentRegular -> confUnpack
$ _lconfig_indentAmount
$ _conf_layout
$ config
BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->
VerticalSpacing (lsp + addInd) psp parFlag
BDFNonBottomSpacing bd -> do
mVs <- rec bd
return $ if null mVs
then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False]
else mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways i
VerticalSpacingParSome i -> VerticalSpacingParAlways i
}
BDFSetParSpacing bd -> do
mVs <- rec bd
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 ]
BDFProhibitMTEL bd -> rec bd
BDFDebug s bd -> do
r <- rec bd
tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r)
return r
#if INSERTTRACESGETSPACING
case brdc of
BDFAnnotationPrior{} -> return ()
BDFAnnotationRest{} -> return ()
_ -> mTell $ Seq.fromList ["getSpacing: visiting: "
++ show {-(toConstr $ brdc)-} (briDocToDoc $ unwrapBriDocNumbered (0, brdc))
, " -> "
++ show (take 9 result)
]
#endif
return result
maxVs :: [VerticalSpacing] -> VerticalSpacing
maxVs = foldl'
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->
VerticalSpacing
(max x1 y1)
(case (x2, y2) of
(x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y)
False)
(VerticalSpacing 0 VerticalSpacingParNone False)
sumVs :: [VerticalSpacing] -> VerticalSpacing
sumVs sps = foldl' go initial sps
where
go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing
(x1 + y1)
(case (x2, y2) of
(x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)
x3
singleline x = _vs_paragraph x == VerticalSpacingParNone
isPar x = _vs_parFlag x
parFlag = case sps of
[] -> True
_ -> all singleline (List.init sps) && isPar (List.last sps)
initial = VerticalSpacing 0 VerticalSpacingParNone parFlag
getMaxVS :: VerticalSpacing -> Int
getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of
VerticalSpacingParSome i -> i
VerticalSpacingParNone -> 0
VerticalSpacingParAlways i -> i
spMakePar :: VerticalSpacing -> VerticalSpacingPar
spMakePar (VerticalSpacing x1 x2 _) = case x2 of
VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i
VerticalSpacingParNone -> VerticalSpacingParSome $ x1
VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i

136
src/Language/Haskell/Brittany/Transformations/Columns.hs Normal file
View File

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

192
src/Language/Haskell/Brittany/Transformations/Floating.hs Normal file
View File

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

57
src/Language/Haskell/Brittany/Transformations/Indent.hs Normal file
View File

@ -0,0 +1,57 @@
module Language.Haskell.Brittany.Transformations.Indent
( transformSimplifyIndent
)
where
#include "prelude.inc"
import Language.Haskell.Brittany.Utils
import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- prepare layouting by translating BDPar's, replacing them with Indents and
-- floating those in. This gives a more clear picture of what exactly is
-- affected by what amount of indentation.
transformSimplifyIndent :: BriDoc -> BriDoc
transformSimplifyIndent = Uniplate.rewrite $ \case
BDPar ind (BDLines lines) indented ->
Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]
BDPar ind (BDCols sig cols) indented ->
Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])
BDPar BrIndentNone _ _ -> Nothing
BDPar ind x indented ->
Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented)
-- BDPar ind x indented ->
-- Just $ BDLines
-- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented
-- ]
BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines ->
Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l
x -> [x]
BDLines [l] -> Just l
BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i x)
BDAddBaseY i (BDAnnotationKW k kw x) ->
Just $ BDAnnotationKW k kw (BDAddBaseY i x)
BDAddBaseY i (BDAnnotationRest k x) ->
Just $ BDAnnotationRest k (BDAddBaseY i x)
BDAddBaseY i (BDSeq l) ->
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY i (BDCols sig l) ->
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} -> Just lit
_ -> Nothing

51
src/Language/Haskell/Brittany/Transformations/Par.hs Normal file
View File

@ -0,0 +1,51 @@
module Language.Haskell.Brittany.Transformations.Par
( transformSimplifyPar
)
where
#include "prelude.inc"
import Language.Haskell.Brittany.Utils
import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
transformSimplifyPar :: BriDoc -> BriDoc
transformSimplifyPar = transformUp $ \case
-- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2]
-- BDPar line indented ->
-- Just $ BDLines [line, indented]
-- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 ->
-- Just $ BDPar ind1 line (BDLines [p1, p2])
x@(BDPar _ (BDPar _ BDPar{} _) _) -> x
BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->
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{} -> True
BDEmpty{} -> True
_ -> False
)
lines -> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
where
go = (=<<) $ \case
BDLines l -> go l
BDEmpty -> []
x -> [x]
BDLines [] -> BDEmpty
BDLines [x] -> x
-- BDCols sig cols | BDPar ind line indented <- List.last cols ->
-- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented
-- BDPar BrIndentNone line indented ->
-- Just $ BDLines [line, indented]
BDEnsureIndent BrIndentNone x -> x
x -> x

4
src/Language/Haskell/Brittany/Types.hs
View File

@ -350,6 +350,10 @@ unwrapBriDocNumbered tpl = case snd tpl of
where where
rec = unwrapBriDocNumbered rec = unwrapBriDocNumbered
isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False
isNotEmpty _ = True
-- this might not work. is not used anywhere either. -- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> () briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case briDocSeqSpine = \case

13
src/Language/Haskell/Brittany/Utils.hs
View File

@ -20,6 +20,8 @@ module Language.Haskell.Brittany.Utils
, briDocToDocWithAnns , briDocToDocWithAnns
, breakEither , breakEither
, spanMaybe , spanMaybe
, transformUp
, transformDownMay
) )
where where
@ -263,3 +265,14 @@ spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)
where where
(ys, xs) = spanMaybe f xR (ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs) spanMaybe _ xs = ([], xs)
-- TODO: move to uniplate upstream?
-- aka `transform`
transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
transformUp f = g where g = f . Uniplate.descend g
_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
_transformDown f = g where g = Uniplate.descend g . f
transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x
_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x

3
srcinc/prelude.inc
View File

@ -522,6 +522,9 @@ import Prelude ( Char
, Traversable , Traversable
) )
import Data.Function ( fix
)
import Data.Foldable ( foldl' import Data.Foldable ( foldl'
, foldr' , foldr'
, fold , fold