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

Improve comment handling (Add KW node; annotation transform)

pull/3/head
Lennart Spitzner 2016-08-11 13:31:13 +02:00
parent 5409b86adf
commit 5166b3dd9e
10 changed files with 384 additions and 234 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -43,6 +43,8 @@ import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import HsSyn import HsSyn
import Data.HList.HList
-- LayoutErrors can be non-fatal warnings, thus both are returned instead -- LayoutErrors can be non-fatal warnings, thus both are returned instead
@ -55,18 +57,16 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([LayoutError], TextL.Text) -> ([LayoutError], TextL.Text)
pPrintModule conf anns parsedModule = pPrintModule conf anns parsedModule =
let ((), (annsBalanced, _), _) = let ((out, errs), debugStrings)
ExactPrint.runTransform anns (commentAnnFixTransform parsedModule)
((out, errs), debugStrings)
= runIdentity = runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiReader annsBalanced $ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader conf $ MultiRWSS.withMultiReader conf
$ do $ do
traceIfDumpConf "bridoc annotations" _dconf_dump_annotations $ annsDoc annsBalanced traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns
ppModule parsedModule ppModule parsedModule
tracer = if Seq.null debugStrings tracer = if Seq.null debugStrings
then id then id
@ -174,15 +174,29 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY) in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY)
_ -> return () _ -> return ()
withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM ()
withTransformedAnns ast m = do
-- TODO: implement `local` for MultiReader/MultiRWS
readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR
MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)
m
MultiRWSS.mPutRawR readers
where
f anns =
let ((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced
ppDecl :: LHsDecl RdrName -> PPM () ppDecl :: LHsDecl RdrName -> PPM ()
ppDecl d@(L loc decl) = case decl of ppDecl d@(L loc decl) = case decl of
SigD sig -> -- trace (_sigHead sig) $ SigD sig -> -- trace (_sigHead sig) $
do withTransformedAnns d $ do
-- runLayouter $ Old.layoutSig (L loc sig) -- runLayouter $ Old.layoutSig (L loc sig)
briDoc <- briDocMToPPM $ layoutSig (L loc sig) briDoc <- briDocMToPPM $ layoutSig (L loc sig)
layoutBriDoc d briDoc layoutBriDoc d briDoc
ValD bind -> -- trace (_bindHead bind) $ ValD bind -> -- trace (_bindHead bind) $
do withTransformedAnns d $ do
-- Old.layoutBind (L loc bind) -- Old.layoutBind (L loc bind)
briDoc <- briDocMToPPM $ do briDoc <- briDocMToPPM $ do
eitherNode <- layoutBind (L loc bind) eitherNode <- layoutBind (L loc bind)

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

@ -99,6 +99,8 @@ layoutBriDoc ast briDoc = do
anns :: ExactPrint.Types.Anns <- mAsk anns :: ExactPrint.Types.Anns <- mAsk
let filteredAnns = filterAnns ast anns let filteredAnns = filterAnns ast anns
traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations $ annsDoc filteredAnns
let state = LayoutState let state = LayoutState
{ _lstate_baseYs = [0] { _lstate_baseYs = [0]
@ -108,8 +110,7 @@ layoutBriDoc ast briDoc = do
-- thing properly. -- thing properly.
, _lstate_indLevels = [0] , _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0 , _lstate_indLevelLinger = 0
, _lstate_commentsPrior = extractCommentsPrior filteredAnns , _lstate_comments = filteredAnns
, _lstate_commentsPost = extractCommentsPost filteredAnns
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
@ -118,9 +119,9 @@ layoutBriDoc ast briDoc = do
state' <- MultiRWSS.withMultiStateS state state' <- MultiRWSS.withMultiStateS state
$ layoutBriDocM briDoc' $ layoutBriDocM briDoc'
let remainingComments = Map.elems (_lstate_commentsPrior state') let remainingComments =
++ Map.elems (_lstate_commentsPost state') extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst) remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
return $ () return $ ()
@ -204,7 +205,7 @@ transformAlts briDoc
-- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd
-- BDExternal k ks c t -> return $ BDFExternal k ks c t -- BDExternal k ks c t -> return $ BDFExternal k ks c t
-- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd
-- BDAnnotationPost annKey bd -> BDFAnnotationPost annKey <$> go bd -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd
-- BDLines lines -> BDFLines <$> go `mapM` lines -- BDLines lines -> BDFLines <$> go `mapM` lines
-- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd
-- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd
@ -218,7 +219,7 @@ transformAlts briDoc
acp :: AltCurPos <- mGet acp :: AltCurPos <- mGet
tellDebugMess $ "transformAlts: visiting: " ++ case brDc of tellDebugMess $ "transformAlts: visiting: " ++ case brDc of
BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp) BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp)
BDFAnnotationPost annKey _ -> show (toConstr brDc, annKey, acp) BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp)
_ -> show (toConstr brDc, acp) _ -> show (toConstr brDc, acp)
#endif #endif
let reWrap = (,) brDcId let reWrap = (,) brDcId
@ -392,8 +393,10 @@ transformAlts briDoc
mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
bd' <- rec bd bd' <- rec bd
return $ reWrap $ BDFAnnotationPrior annKey bd' return $ reWrap $ BDFAnnotationPrior annKey bd'
BDFAnnotationPost annKey bd -> BDFAnnotationRest annKey bd ->
reWrap . BDFAnnotationPost annKey <$> rec 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 [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.
BDFLines (l:lr) -> do BDFLines (l:lr) -> do
ind <- _acp_indent <$> mGet ind <- _acp_indent <$> mGet
@ -536,7 +539,8 @@ getSpacing !bridoc = rec bridoc
$ LineModeValid $ LineModeValid
$ VerticalSpacing 999 VerticalSpacingParNone False $ VerticalSpacing 999 VerticalSpacingParNone False
BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationPrior _annKey bd -> rec bd
BDFAnnotationPost _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFLines [] -> return BDFLines [] -> return
$ LineModeValid $ LineModeValid
$ VerticalSpacing 0 VerticalSpacingParNone False $ VerticalSpacing 0 VerticalSpacingParNone False
@ -725,7 +729,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ [] -- yes, we just assume that we cannot properly layout return $ [] -- yes, we just assume that we cannot properly layout
-- this. -- this.
BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationPrior _annKey bd -> rec bd
BDFAnnotationPost _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLines ls@(_:_) -> do BDFLines ls@(_:_) -> do
-- we simply assume that lines is only used "properly", i.e. in -- we simply assume that lines is only used "properly", i.e. in
@ -784,7 +789,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
#if INSERTTRACESGETSPACING #if INSERTTRACESGETSPACING
case brdc of case brdc of
BDFAnnotationPrior{} -> return () BDFAnnotationPrior{} -> return ()
BDFAnnotationPost{} -> return () BDFAnnotationRest{} -> return ()
_ -> mTell $ Seq.fromList ["getSpacing: visiting: " _ -> mTell $ Seq.fromList ["getSpacing: visiting: "
++ show {-(toConstr $ brdc)-} (briDocToDoc $ unwrapBriDocNumbered (0, brdc)) ++ show {-(toConstr $ brdc)-} (briDocToDoc $ unwrapBriDocNumbered (0, brdc))
, " -> " , " -> "
@ -863,21 +868,6 @@ transformSimplifyFloating = stepBO .> stepFull
-- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence
-- the push/pop cases would need to be copied over -- the push/pop cases would need to be copied over
where where
descendPost = transformDownMay $ \case
-- post floating in
BDAnnotationPost annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationPost annKey1 indented
BDAnnotationPost annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list]
BDAnnotationPost annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list]
BDAnnotationPost annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols]
BDAnnotationPost annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPost annKey1 x
BDAnnotationPost annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationPost annKey1 x
_ -> Nothing
descendPrior = transformDownMay $ \case descendPrior = transformDownMay $ \case
-- prior floating in -- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) -> BDAnnotationPrior annKey1 (BDPar ind line indented) ->
@ -893,6 +883,36 @@ transformSimplifyFloating = stepBO .> stepFull
BDAnnotationPrior annKey1 (BDDebug s x) -> BDAnnotationPrior annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationPrior annKey1 x Just $ BDDebug s $ BDAnnotationPrior annKey1 x
_ -> Nothing _ -> Nothing
descendRest = transformDownMay $ \case
-- 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 descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_:_)) -> BDBaseYPushCur (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
@ -931,8 +951,10 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationPost annKey1 x) -> BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
Just $ BDAnnotationPost annKey1 (BDAddBaseY ind x) Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} -> BDAddBaseY _ lit@BDLit{} ->
@ -950,7 +972,8 @@ transformSimplifyFloating = stepBO .> stepFull
where where
f = \case f = \case
x@BDAnnotationPrior{} -> descendPrior x x@BDAnnotationPrior{} -> descendPrior x
x@BDAnnotationPost{} -> descendPost x x@BDAnnotationKW{} -> descendKW x
x@BDAnnotationRest{} -> descendRest x
x@BDAddBaseY{} -> descendAddB x x@BDAddBaseY{} -> descendAddB x
x@BDBaseYPushCur{} -> descendBYPush x x@BDBaseYPushCur{} -> descendBYPush x
x@BDBaseYPop{} -> descendBYPop x x@BDBaseYPop{} -> descendBYPop x
@ -995,14 +1018,14 @@ transformSimplifyFloating = stepBO .> stepFull
-- BDEnsureIndent indent (BDLines lines) -> -- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines -- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- post floating in -- post floating in
BDAnnotationPost annKey1 (BDPar ind line indented) -> BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationPost annKey1 indented Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationPost annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationPost annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationPost annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols] Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
_ -> Nothing _ -> Nothing
transformSimplifyPar :: BriDoc -> BriDoc transformSimplifyPar :: BriDoc -> BriDoc
@ -1068,12 +1091,18 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)
-- post floating in -- post floating in
BDAnnotationPost annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationPost annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationPost annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols] Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
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 -- ensureIndent float-in
-- not sure if the following rule is necessary; tests currently are -- not sure if the following rule is necessary; tests currently are
-- unaffected. -- unaffected.
@ -1145,7 +1174,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDExternal{} -> Nothing BDExternal{} -> Nothing
BDLines{} -> Nothing BDLines{} -> Nothing
BDAnnotationPrior{} -> Nothing BDAnnotationPrior{} -> Nothing
BDAnnotationPost{} -> Nothing BDAnnotationKW{} -> Nothing
BDAnnotationRest{} -> Nothing
BDEnsureIndent{} -> Nothing BDEnsureIndent{} -> Nothing
BDProhibitMTEL{} -> Nothing BDProhibitMTEL{} -> Nothing
BDSetParSpacing{} -> Nothing BDSetParSpacing{} -> Nothing
@ -1173,10 +1203,12 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
Just $ BDLines $ filter isNotEmpty $ lines >>= \case Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
BDAddBaseY i (BDAnnotationPost k x) ->
Just $ BDAnnotationPost k (BDAddBaseY i x)
BDAddBaseY i (BDAnnotationPrior k x) -> BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i 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) -> BDAddBaseY i (BDSeq l) ->
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY i (BDCols sig l) -> BDAddBaseY i (BDCols sig l) ->
@ -1210,7 +1242,8 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t BDExternal _ _ _ t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd BDAnnotationPrior _ bd -> rec bd
BDAnnotationPost _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDLines (l:_) -> rec l BDLines (l:_) -> rec l
BDLines [] -> error "briDocLineLength BDLines []" BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
@ -1305,64 +1338,105 @@ layoutBriDocM = \case
state <- mGet state <- mGet
let filterF k _ = not $ k `Set.member` subKeys let filterF k _ = not $ k `Set.member` subKeys
mSet $ state mSet $ state
{ _lstate_commentsPrior = Map.filterWithKey filterF { _lstate_comments = Map.filterWithKey filterF
$ _lstate_commentsPrior state $ _lstate_comments state
, _lstate_commentsPost = Map.filterWithKey filterF
$ _lstate_commentsPost state
} }
BDAnnotationPrior annKey bd -> do BDAnnotationPrior annKey bd -> do
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 state <- mGet
let m = _lstate_commentsPrior state let m = _lstate_comments state
let allowMTEL = not (_lstate_inhibitMTEL state) let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
&& Data.Either.isRight (_lstate_curYOrAddNewline state) let mToSpan = case mAnn of
mAnn <- do Just anns | keyword==Nothing -> Just anns
let mAnn = Map.lookup annKey m Just ((ExactPrint.Types.G kw1, _):annR)
mSet $ state { _lstate_commentsPrior = Map.delete annKey m } | keyword==Just kw1 -> Just annR
return mAnn _ -> Nothing
case mAnn of case mToSpan of
Nothing -> when allowMTEL $ moveToExactAnn annKey Just anns -> do
Just [] -> when allowMTEL $ moveToExactAnn annKey let (comments, rest) = flip spanMaybe anns $ \case
Just priors -> do (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
-- layoutResetSepSpace _ -> Nothing
priors `forM_` \( ExactPrint.Types.Comment comment _ _ 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) , ExactPrint.Types.DP (y, x)
) -> do ) -> do
-- evil hack for CPP: -- evil hack for CPP:
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) ('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x _ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y -- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
when allowMTEL $ moveToExactAnn annKey BDAnnotationRest annKey bd -> do
layoutBriDocM bd layoutBriDocM bd
BDAnnotationPost annKey bd -> do mAnn <- do
layoutBriDocM bd state <- mGet
do let m = _lstate_comments state
mAnn <- do let mAnn = extractAllComments <$> Map.lookup annKey m
state <- mGet mSet $ state
let m = _lstate_commentsPost state { _lstate_comments =
let mAnn = Map.lookup annKey m Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = []
mSet $ state { _lstate_commentsPost = Map.delete annKey m } , ExactPrint.annPriorComments = []
return mAnn , ExactPrint.annsDP = []
case mAnn of }
Nothing -> return () )
Just posts -> do annKey
posts `forM_` \( ExactPrint.Types.Comment comment _ _ m
}
return mAnn
forM_ mAnn $ mapM_ $ \( ExactPrint.Types.Comment comment _ _
, ExactPrint.Types.DP (y, x) , ExactPrint.Types.DP (y, x)
) -> do ) -> do
-- evil hack for CPP: -- evil hack for CPP:
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) ('#':_) -> layoutMoveToCommentPos y (-999)
_ -> layoutMoveToCommentPos y x _ -> layoutMoveToCommentPos y x
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y -- layoutMoveToIndentCol y
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDNonBottomSpacing bd -> layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd

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

@ -4,6 +4,7 @@ module Language.Haskell.Brittany.ExactPrintUtils
( parseModule ( parseModule
, parseModuleFromString , parseModuleFromString
, commentAnnFixTransform , commentAnnFixTransform
, commentAnnFixTransformGlob
) )
where where
@ -54,6 +55,9 @@ 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.LayoutBasics
import Language.Haskell.Brittany.Utils
import DataTreePrint
@ -114,16 +118,67 @@ parseModuleFromString args fp str =
----------- -----------
-- data LNode = forall a . LNode (Located a) commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
-- commentAnnFixTransformGlob ast = do
-- commentAnnFixTransformGlob :: GHC.ParsedSource -> ExactPrint.Transform () let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
-- commentAnnFixTransformGlob modul = do extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
-- let extract :: forall a . SYB.Data a => a -> Seq LNode const Seq.empty `SYB.ext2Q` (\(L a b) -> f1 a b)
-- extract = const Seq.empty `SYB.ext1Q` (Seq.singleton . LNode) where
-- let nodes = SYB.everything (<>) extract modul f1 b c = (const Seq.empty `SYB.extQ` f2 c) b
-- let comp = _ f2 c l = Seq.singleton (l, ExactPrint.mkAnnKey (L l c))
-- let sorted = Seq.sortBy (comparing _) nodes -- i wonder if there is a way to avoid re-constructing the L above..
-- _ let nodes = SYB.everything (<>) extract ast
let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith
(flip const)
[ (GHC.realSrcSpanEnd span, annKey)
| (GHC.RealSrcSpan span, annKey) <- Foldable.toList nodes
]
nodes `forM_` (snd .> processComs annsMap)
where
processComs annsMap annKey1 = do
mAnn <- State.Class.gets fst <&> Map.lookup annKey1
mAnn `forM_` \ann1 -> do
let priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
-> ExactPrint.TransformT Identity Bool
processCom comPair@(com, _) =
case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of
GHC.UnhelpfulLoc{} -> return True -- retain comment at current node.
GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False
(x,y) | x==y -> move $> False
_ -> return True
where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.srcSpanStart annKeyLoc1
loc2 = GHC.srcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns ->
let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2
{ ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair]
}
in Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node.
priors' <- flip filterM priors processCom
follows' <- flip filterM follows $ processCom
assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True
let ann1' = ann1 { ExactPrint.annPriorComments = priors'
, ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs'
}
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
commentAnnFixTransform modul = SYB.everything (>>) genF modul commentAnnFixTransform modul = SYB.everything (>>) genF modul
@ -142,14 +197,6 @@ moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
=> GHC.Located a -> GHC.Located b -> ExactPrint.Transform () => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
moveTrailingComments astFrom astTo = do moveTrailingComments astFrom astTo = do
let let
breakHet :: (a -> Either b c) -> [a] -> ([b],[c])
breakHet _ [] = ([],[])
breakHet fn (a1:aR) = case fn a1 of
Left b -> (b:bs,cs)
Right c -> (bs,c:cs)
where
(bs,cs) = breakHet fn aR
k1 = ExactPrint.mkAnnKey astFrom k1 = ExactPrint.mkAnnKey astFrom
k2 = ExactPrint.mkAnnKey astTo k2 = ExactPrint.mkAnnKey astTo
moveComments ans = ans' moveComments ans = ans'
@ -158,7 +205,7 @@ moveTrailingComments astFrom astTo = do
an2 = Data.Maybe.fromJust $ Map.lookup k2 ans an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
cs1f = ExactPrint.annFollowingComments an1 cs1f = ExactPrint.annFollowingComments an1
cs2f = ExactPrint.annFollowingComments an2 cs2f = ExactPrint.annFollowingComments an2
(comments, nonComments) = flip breakHet (ExactPrint.annsDP an1) (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)
$ \case $ \case
(ExactPrint.AnnComment com, dp) -> Left (com, dp) (ExactPrint.AnnComment com, dp) -> Left (com, dp)
x -> Right x x -> Right x

130
src/Language/Haskell/Brittany/LayoutBasics.hs
View File

@ -37,8 +37,7 @@ module Language.Haskell.Brittany.LayoutBasics
, layoutWritePriorComments , layoutWritePriorComments
, layoutWritePostComments , layoutWritePostComments
, layoutRemoveIndentLevelLinger , layoutRemoveIndentLevelLinger
, extractCommentsPrior , extractAllComments
, extractCommentsPost
, filterAnns , filterAnns
, ppmMoveToExactLoc , ppmMoveToExactLoc
, docEmpty , docEmpty
@ -48,10 +47,10 @@ module Language.Haskell.Brittany.LayoutBasics
, docCols , docCols
, docSeq , docSeq
, docPar , docPar
, docPostComment , docNodeAnnKW
, docWrapNode , docWrapNode
, docWrapNodePrior , docWrapNodePrior
, docWrapNodePost , docWrapNodeRest
, docForceSingleline , docForceSingleline
, docForceMultiline , docForceMultiline
, docEnsureIndent , docEnsureIndent
@ -60,7 +59,8 @@ module Language.Haskell.Brittany.LayoutBasics
, docSetIndentLevel , docSetIndentLevel
, docSeparator , docSeparator
, docAnnotationPrior , docAnnotationPrior
, docAnnotationPost , docAnnotationKW
, docAnnotationRest
, docNonBottomSpacing , docNonBottomSpacing
, docSetParSpacing , docSetParSpacing
, docForceParSpacing , docForceParSpacing
@ -86,9 +86,10 @@ where
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation, KeywordId )
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
@ -638,10 +639,13 @@ layoutWritePriorComments :: (Data.Data.Data ast,
layoutWritePriorComments ast = do layoutWritePriorComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let key = ExactPrint.Types.mkAnnKey ast let key = ExactPrint.Types.mkAnnKey ast
let m = _lstate_commentsPrior state let anns = _lstate_comments state
let mAnn = Map.lookup key m let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state { _lstate_commentsPrior = Map.delete key m } mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns
}
return mAnn return mAnn
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutWritePriorComments", ExactPrint.Types.mkAnnKey ast, mAnn) tellDebugMessShow ("layoutWritePriorComments", ExactPrint.Types.mkAnnKey ast, mAnn)
@ -668,10 +672,15 @@ layoutWritePostComments :: (Data.Data.Data ast,
layoutWritePostComments ast = do layoutWritePostComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let key = ExactPrint.Types.mkAnnKey ast let key = ExactPrint.Types.mkAnnKey ast
let m = _lstate_commentsPost state let anns = _lstate_comments state
let mAnn = Map.lookup key m let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state { _lstate_commentsPost = Map.delete key m } mSet $ state
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })
key
anns
}
return mAnn return mAnn
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutWritePostComments", ExactPrint.Types.mkAnnKey ast, mAnn) tellDebugMessShow ("layoutWritePostComments", ExactPrint.Types.mkAnnKey ast, mAnn)
@ -725,30 +734,26 @@ layoutIndentRestorePostComment = do
-- layoutWritePostComments x -- layoutWritePostComments x
-- layoutIndentRestorePostComment -- layoutIndentRestorePostComment
extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap extractAllComments
extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann -> :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
[r | let r = ExactPrint.Types.annPriorComments ann, not (null r)] extractAllComments ann =
extractCommentsPost :: ExactPrint.Types.Anns -> PostMap ExactPrint.annPriorComments ann
extractCommentsPost anns = flip Map.mapMaybe anns $ \ann -> ++ ExactPrint.annFollowingComments ann
[ r ++ (ExactPrint.annsDP ann >>= \case
| let annDPs = ExactPrint.Types.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)]
(ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)] _ -> []
_ -> [] )
, let following = ExactPrint.Types.annFollowingComments ann
, let r = following ++ annDPs
, not (null r)
]
foldedAnnKeys :: Data.Data.Data ast foldedAnnKeys :: Data.Data.Data ast
=> ast => ast
-> Set ExactPrint.Types.AnnKey -> Set ExactPrint.AnnKey
foldedAnnKeys ast = everything foldedAnnKeys ast = everything
Set.union Set.union
(\x -> maybe (\x -> maybe
Set.empty Set.empty
Set.singleton Set.singleton
[ gmapQi 1 (\t -> ExactPrint.Types.mkAnnKey $ L l t) x [ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
| locTyCon == typeRepTyCon (typeOf x) | locTyCon == typeRepTyCon (typeOf x)
, l <- gmapQi 0 cast x , l <- gmapQi 0 cast x
] ]
@ -759,8 +764,8 @@ foldedAnnKeys ast = everything
filterAnns :: Data.Data.Data ast filterAnns :: Data.Data.Data ast
=> ast => ast
-> ExactPrint.Types.Anns -> ExactPrint.Anns
-> ExactPrint.Types.Anns -> ExactPrint.Anns
filterAnns ast anns = filterAnns ast anns =
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns
@ -927,11 +932,17 @@ docSetIndentLevel bdm = do
docSeparator :: ToBriDocM BriDocNumbered docSeparator :: ToBriDocM BriDocNumbered
docSeparator = allocateNode BDFSeparator docSeparator = allocateNode BDFSeparator
docAnnotationPrior :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAnnotationPrior
:: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
docAnnotationPost :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAnnotationKW
docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm :: AnnKey -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
docAnnotationRest
:: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm
docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm
@ -954,29 +965,14 @@ docCommaSep = appSep $ docLit $ Text.pack ","
docParenLSep :: ToBriDocM BriDocNumbered docParenLSep :: ToBriDocM BriDocNumbered
docParenLSep = appSep $ docLit $ Text.pack "(" docParenLSep = appSep $ docLit $ Text.pack "("
docNodeAnnKW
docPostComment :: (Data.Data.Data ast) :: Data.Data.Data ast
=> GenLocated SrcSpan ast => GenLocated SrcSpan ast
-> ToBriDocM BriDocNumbered -> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docPostComment ast bdm = do -> ToBriDocM BriDocNumbered
bd <- bdm docNodeAnnKW ast kw bdm =
allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm
-- docWrapNode :: ( Data.Data.Data ast)
-- => GenLocated SrcSpan ast
-- -> ToBriDocM BriDocNumbered
-- -> ToBriDocM BriDocNumbered
-- docWrapNode ast bdm = do
-- bd <- bdm
-- i1 <- allocNodeIndex
-- i2 <- allocNodeIndex
-- return
-- $ (,) i1
-- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
-- $ (,) i2
-- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
-- $ bd
class DocWrapable a where class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast) docWrapNode :: ( Data.Data.Data ast)
@ -987,7 +983,7 @@ class DocWrapable a where
=> GenLocated SrcSpan ast => GenLocated SrcSpan ast
-> ToBriDocM a -> ToBriDocM a
-> ToBriDocM a -> ToBriDocM a
docWrapNodePost :: ( Data.Data.Data ast) docWrapNodeRest :: ( Data.Data.Data ast)
=> GenLocated SrcSpan ast => GenLocated SrcSpan ast
-> ToBriDocM a -> ToBriDocM a
-> ToBriDocM a -> ToBriDocM a
@ -1001,7 +997,7 @@ instance DocWrapable BriDocNumbered where
$ (,) i1 $ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ (,) i2 $ (,) i2
$ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd $ bd
docWrapNodePrior ast bdm = do docWrapNodePrior ast bdm = do
bd <- bdm bd <- bdm
@ -1010,12 +1006,12 @@ instance DocWrapable BriDocNumbered where
$ (,) i1 $ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd $ bd
docWrapNodePost ast bdm = do docWrapNodeRest ast bdm = do
bd <- bdm bd <- bdm
i2 <- allocNodeIndex i2 <- allocNodeIndex
return return
$ (,) i2 $ (,) i2
$ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd $ bd
instance DocWrapable a => DocWrapable [a] where instance DocWrapable a => DocWrapable [a] where
@ -1028,7 +1024,7 @@ instance DocWrapable a => DocWrapable [a] where
return [bd'] return [bd']
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> do (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodePost ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ [bd1'] ++ reverse bdM ++ [bdN'] return $ [bd1'] ++ reverse bdM ++ [bdN']
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
docWrapNodePrior ast bdsm = do docWrapNodePrior ast bdsm = do
@ -1038,12 +1034,12 @@ instance DocWrapable a => DocWrapable [a] where
(bd1:bdR) -> do (bd1:bdR) -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
return $ (bd1':bdR) return $ (bd1':bdR)
docWrapNodePost ast bdsm = do docWrapNodeRest ast bdsm = do
bds <- bdsm bds <- bdsm
case reverse bds of case reverse bds of
[] -> return $ [] [] -> return $ []
(bdN:bdR) -> do (bdN:bdR) -> do
bdN' <- docWrapNodePost ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse $ (bdN':bdR) return $ reverse $ (bdN':bdR)
instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
@ -1055,15 +1051,15 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
return $ (bds, bd', x) return $ (bds, bd', x)
else do else do
bds' <- docWrapNodePrior ast (return bds) bds' <- docWrapNodePrior ast (return bds)
bd' <- docWrapNodePost ast (return bd) bd' <- docWrapNodeRest ast (return bd)
return $ (bds', bd', x) return $ (bds', bd', x)
docWrapNodePrior ast stuffM = do docWrapNodePrior ast stuffM = do
(bds, bd, x) <- stuffM (bds, bd, x) <- stuffM
bds' <- docWrapNodePrior ast (return bds) bds' <- docWrapNodePrior ast (return bds)
return $ (bds', bd, x) return $ (bds', bd, x)
docWrapNodePost ast stuffM = do docWrapNodeRest ast stuffM = do
(bds, bd, x) <- stuffM (bds, bd, x) <- stuffM
bd' <- docWrapNodePost ast (return bd) bd' <- docWrapNodeRest ast (return bd)
return $ (bds, bd', x) return $ (bds, bd', x)

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

@ -44,13 +44,13 @@ layoutSig lsig@(L _loc sig) = docWrapNode lsig $ case sig of
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
docAlt docAlt
[ docSeq [ docSeq
[ appSep $ docPostComment lsig $ docLit nameStr [ appSep $ docWrapNodeRest lsig $ docLit nameStr
, appSep $ docLit $ Text.pack "::" , appSep $ docLit $ Text.pack "::"
, docForceSingleline typeDoc , docForceSingleline typeDoc
] ]
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar $ docPar
(docPostComment lsig $ docLit nameStr) (docWrapNodeRest lsig $ docLit nameStr)
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docLit $ Text.pack ":: " [ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) $ typeDoc , docAddBaseY (BrIndentSpecial 3) $ typeDoc
@ -139,7 +139,7 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs
: (spacifyDocs $ docForceSingleline <$> ps) : (spacifyDocs $ docForceSingleline <$> ps)
(Nothing, ps) -> docCols ColPatterns (Nothing, ps) -> docCols ColPatterns
$ (List.intersperse docSeparator $ docForceSingleline <$> ps) $ (List.intersperse docSeparator $ docForceSingleline <$> ps)
clauseDocs <- docWrapNodePost lmatch $ layoutGrhs `mapM` grhss clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds mWhereDocs <- layoutLocalBinds whereBinds
layoutPatternBindFinal binderDoc (Just patDoc) clauseDocs mWhereDocs layoutPatternBindFinal binderDoc (Just patDoc) clauseDocs mWhereDocs

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

@ -15,7 +15,7 @@ import Language.Haskell.Brittany.Types
import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany.LayoutBasics
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import HsSyn import HsSyn
import Name import Name
@ -467,9 +467,12 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
briDocByExact lexpr briDocByExact lexpr
RecordCon lname _ _ (HsRecFields [] Nothing) -> do RecordCon lname _ _ (HsRecFields [] Nothing) -> do
let t = lrdrNameToText lname let t = lrdrNameToText lname
docLit $ t <> Text.pack "{}" docWrapNode lname $ docSeq
[ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{"
, docLit $ Text.pack "}"
]
RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do
let t = lrdrNameToText lname let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
@ -479,15 +482,15 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
[ docSetParSpacing [ docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar
(docLit t) (docNodeAnnKW lexpr Nothing $ nameDoc)
(docNonBottomSpacing $ docLines $ let (docNonBottomSpacing $ docLines $ let
line1 = docCols ColRecUpdate line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{" [ appSep $ docLit $ Text.pack "{"
, appSep $ docLit $ fd1n , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n
, case fd1e of , case fd1e of
Just x -> docSeq Just x -> docSeq
[ appSep $ docLit $ Text.pack "=" [ appSep $ docLit $ Text.pack "="
, docWrapNode fd1l $ docAddBaseY BrIndentRegular $ x , docWrapNodeRest fd1l $ docAddBaseY BrIndentRegular $ x
] ]
Nothing -> docEmpty Nothing -> docEmpty
] ]
@ -495,9 +498,9 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
[ appSep $ docLit $ Text.pack "," [ appSep $ docLit $ Text.pack ","
, appSep $ docLit $ fText , appSep $ docLit $ fText
, case fDoc of , case fDoc of
Just x -> docSeq Just x -> docWrapNode lfield $ docSeq
[ appSep $ docLit $ Text.pack "=" [ appSep $ docLit $ Text.pack "="
, docWrapNode lfield $ docAddBaseY BrIndentRegular x , docAddBaseY BrIndentRegular x
] ]
Nothing -> docEmpty Nothing -> docEmpty
] ]

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

@ -113,7 +113,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
forallDoc forallDoc
( docLines ( docLines
[ docCols ColTyOpPrefix [ docCols ColTyOpPrefix
[ docPostComment ltype $ docLit $ Text.pack " . " [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3) , docAddBaseY (BrIndentSpecial 3)
$ docForceSingleline contextDoc $ docForceSingleline contextDoc
] ]
@ -153,7 +153,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docPar , docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docPostComment ltype $ docLit $ Text.pack ". " [ docWrapNodeRest ltype $ docLit $ Text.pack ". "
, return typeDoc , return typeDoc
] ]
) )
@ -176,7 +176,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
) )
++[ docCols ColTyOpPrefix ++[ docCols ColTyOpPrefix
[ docPostComment ltype $ docLit $ Text.pack ". " [ docWrapNodeRest ltype $ docLit $ Text.pack ". "
, return typeDoc , return typeDoc
] ]
] ]
@ -239,13 +239,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
docAlt docAlt
[ docSeq [ docSeq
[ docForceSingleline typeDoc1 [ docForceSingleline typeDoc1
, docPostComment ltype $ appSep $ docLit $ Text.pack " ->" , docWrapNodeRest ltype $ appSep $ docLit $ Text.pack " ->"
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
] ]
, docPar , docPar
typeDoc1 typeDoc1
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docPostComment ltype $ appSep $ docLit $ Text.pack "->" [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3) , docAddBaseY (BrIndentSpecial 3)
$ if shouldForceML then docForceMultiline typeDoc2 $ if shouldForceML then docForceMultiline typeDoc2
else typeDoc2 else typeDoc2
@ -256,13 +256,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docPostComment ltype $ docLit $ Text.pack "(" [ docWrapNodeRest ltype $ docLit $ Text.pack "("
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
, docPar , docPar
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docPostComment ltype $ docParenLSep [ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]) ])
(docLit $ Text.pack ")") (docLit $ Text.pack ")")
@ -322,13 +322,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docPostComment ltype $ docLit $ Text.pack "[" [ docWrapNodeRest ltype $ docLit $ Text.pack "["
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
, docPar , docPar
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docPostComment ltype $ docLit $ Text.pack "[ " [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]) ])
(docLit $ Text.pack "]") (docLit $ Text.pack "]")
@ -337,13 +337,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docPostComment ltype $ docLit $ Text.pack "[:" [ docWrapNodeRest ltype $ docLit $ Text.pack "[:"
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
, docLit $ Text.pack ":]" , docLit $ Text.pack ":]"
] ]
, docPar , docPar
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docPostComment ltype $ docLit $ Text.pack "[:" [ docWrapNodeRest ltype $ docLit $ Text.pack "[:"
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]) ])
(docLit $ Text.pack ":]") (docLit $ Text.pack ":]")
@ -451,7 +451,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docPostComment ltype [ docWrapNodeRest ltype
$ docLit $ docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
@ -461,7 +461,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
) )
(docCols ColTyOpPrefix (docCols ColTyOpPrefix
[ docPostComment ltype [ docWrapNodeRest ltype
$ docLit $ Text.pack "::" $ docLit $ Text.pack "::"
, docAddBaseY (BrIndentSpecial 2) typeDoc1 , docAddBaseY (BrIndentSpecial 2) typeDoc1
]) ])
@ -472,14 +472,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
docAlt docAlt
[ docSeq [ docSeq
[ docForceSingleline typeDoc1 [ docForceSingleline typeDoc1
, docPostComment ltype , docWrapNodeRest ltype
$ docLit $ Text.pack " ~ " $ docLit $ Text.pack " ~ "
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
] ]
, docPar , docPar
typeDoc1 typeDoc1
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docPostComment ltype [ docWrapNodeRest ltype
$ docLit $ Text.pack "~ " $ docLit $ Text.pack "~ "
, docAddBaseY (BrIndentSpecial 2) typeDoc2 , docAddBaseY (BrIndentSpecial 2) typeDoc2
]) ])
@ -497,7 +497,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docPar , docPar
typeDoc1 typeDoc1
( docCols ColTyOpPrefix ( docCols ColTyOpPrefix
[ docPostComment ltype [ docWrapNodeRest ltype
$ docLit $ Text.pack ":: " $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1 , docAddBaseY (BrIndentSpecial 3) kindDoc1
]) ])

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

@ -17,11 +17,11 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import RdrName ( RdrName(..) ) import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment )
import Language.Haskell.GHC.ExactPrint.Types ( Anns, DeltaPos, mkAnnKey ) import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey )
import Language.Haskell.Brittany.Config.Types import Language.Haskell.Brittany.Config.Types
@ -31,9 +31,6 @@ import Data.Generics.Uniplate.Direct as Uniplate
type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [LayoutError], Seq String] '[] a type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [LayoutError], Seq String] '[] a
type PriorMap = Map AnnKey [(Comment, DeltaPos)]
type PostMap = Map AnnKey [(Comment, DeltaPos)]
data LayoutState = LayoutState data LayoutState = LayoutState
{ _lstate_baseYs :: [Int] { _lstate_baseYs :: [Int]
-- ^ stack of number of current indentation columns -- ^ stack of number of current indentation columns
@ -56,10 +53,7 @@ data LayoutState = LayoutState
-- on the first indented element have an -- on the first indented element have an
-- annotation offset relative to the last -- annotation offset relative to the last
-- non-indented element, which is confusing. -- non-indented element, which is confusing.
, _lstate_commentsPrior :: PriorMap -- map of "true" pre-node comments that , _lstate_comments :: Anns
-- really _should_ be included in the
-- output.
, _lstate_commentsPost :: PostMap -- similarly, for post-node comments.
, _lstate_commentCol :: Maybe Int -- this communicates two things: , _lstate_commentCol :: Maybe Int -- this communicates two things:
-- firstly, that cursor is currently -- firstly, that cursor is currently
-- at the end of a comment (so needs -- at the end of a comment (so needs
@ -221,7 +215,8 @@ data BriDoc
Bool -- should print extra comment ? Bool -- should print extra comment ?
Text Text
| BDAnnotationPrior AnnKey BriDoc | BDAnnotationPrior AnnKey BriDoc
| BDAnnotationPost AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc
| BDAnnotationRest AnnKey BriDoc
| BDLines [BriDoc] | BDLines [BriDoc]
| BDEnsureIndent BrIndent BriDoc | BDEnsureIndent BrIndent BriDoc
-- the following constructors are only relevant for the alt transformation -- the following constructors are only relevant for the alt transformation
@ -270,7 +265,8 @@ data BriDocF f
Bool -- should print extra comment ? Bool -- should print extra comment ?
Text Text
| BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationPrior AnnKey (f (BriDocF f))
| BDFAnnotationPost AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))
| BDFAnnotationRest AnnKey (f (BriDocF f))
| BDFLines [(f (BriDocF f))] | BDFLines [(f (BriDocF f))]
| BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFEnsureIndent BrIndent (f (BriDocF f))
| BDFForceMultiline (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f))
@ -307,7 +303,8 @@ instance Uniplate.Uniplate BriDoc where
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x uniplate x@BDExternal{} = plate x
uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationPost annKey bd) = plate BDAnnotationPost |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd
uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd
uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDLines lines) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
@ -337,7 +334,8 @@ unwrapBriDocNumbered tpl = case snd tpl of
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t BDFExternal k ks c t -> BDExternal k ks c t
BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
BDFAnnotationPost annKey bd -> BDAnnotationPost annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFLines lines -> BDLines $ rec <$> lines BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd
@ -367,7 +365,8 @@ briDocSeqSpine = \case
BDForwardLineMode bd -> briDocSeqSpine bd BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> () BDExternal{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationPost _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd

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

@ -17,6 +17,8 @@ module Language.Haskell.Brittany.Utils
, tellDebugMess , tellDebugMess
, tellDebugMessShow , tellDebugMessShow
, briDocToDocWithAnns , briDocToDocWithAnns
, breakEither
, spanMaybe
) )
where where
@ -228,7 +230,8 @@ briDocToDoc = astToDoc . removeAnnotations
where where
removeAnnotations = Uniplate.transform $ \case removeAnnotations = Uniplate.transform $ \case
BDAnnotationPrior _ x -> x BDAnnotationPrior _ x -> x
BDAnnotationPost _ x -> x BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x
x -> x x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns :: BriDoc -> PP.Doc
@ -236,3 +239,17 @@ briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b],[c])
breakEither _ [] = ([],[])
breakEither fn (a1:aR) = case fn a1 of
Left b -> (b:bs,cs)
Right c -> (bs,c:cs)
where
(bs,cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1:xR) | Just y <- f x1 = (y:ys, xs)
where
(ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)

2
srcinc/prelude.inc
View File

@ -373,7 +373,7 @@ import qualified Data.Bool as Bool
-- import qualified Data.Complex as Complex -- import qualified Data.Complex as Complex
-- import qualified Data.Either as Either -- import qualified Data.Either as Either
-- import qualified Data.Eq as Eq -- import qualified Data.Eq as Eq
-- import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
-- import qualified Data.Fixed as Fixed -- import qualified Data.Fixed as Fixed
-- import qualified Data.Functor.Identity as Identity -- import qualified Data.Functor.Identity as Identity
-- import qualified Data.IORef as IORef -- import qualified Data.IORef as IORef