Improve comment handling (Add KW node; annotation transform)
Lennart Spitzner
parent
5409b86adf
commit
5166b3dd9e
|
|
@ -43,6 +43,8 @@ import GHC ( runGhc, GenLocated(L), moduleNameString )
|
|||
import SrcLoc ( SrcSpan )
|
||||
import HsSyn
|
||||
|
||||
import Data.HList.HList
|
||||
|
||||
|
||||
|
||||
-- LayoutErrors can be non-fatal warnings, thus both are returned instead
|
||||
|
|
@ -55,18 +57,16 @@ pPrintModule
|
|||
-> GHC.ParsedSource
|
||||
-> ([LayoutError], TextL.Text)
|
||||
pPrintModule conf anns parsedModule =
|
||||
let ((), (annsBalanced, _), _) =
|
||||
ExactPrint.runTransform anns (commentAnnFixTransform parsedModule)
|
||||
((out, errs), debugStrings)
|
||||
let ((out, errs), debugStrings)
|
||||
= runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterW
|
||||
$ MultiRWSS.withMultiReader annsBalanced
|
||||
$ MultiRWSS.withMultiReader anns
|
||||
$ MultiRWSS.withMultiReader conf
|
||||
$ do
|
||||
traceIfDumpConf "bridoc annotations" _dconf_dump_annotations $ annsDoc annsBalanced
|
||||
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns
|
||||
ppModule parsedModule
|
||||
tracer = if Seq.null debugStrings
|
||||
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)
|
||||
_ -> 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 d@(L loc decl) = case decl of
|
||||
SigD sig -> -- trace (_sigHead sig) $
|
||||
do
|
||||
withTransformedAnns d $ do
|
||||
-- runLayouter $ Old.layoutSig (L loc sig)
|
||||
briDoc <- briDocMToPPM $ layoutSig (L loc sig)
|
||||
layoutBriDoc d briDoc
|
||||
ValD bind -> -- trace (_bindHead bind) $
|
||||
do
|
||||
withTransformedAnns d $ do
|
||||
-- Old.layoutBind (L loc bind)
|
||||
briDoc <- briDocMToPPM $ do
|
||||
eitherNode <- layoutBind (L loc bind)
|
||||
|
|
|
|||
|
|
@ -100,6 +100,8 @@ layoutBriDoc ast briDoc = do
|
|||
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
|
||||
|
|
@ -108,8 +110,7 @@ layoutBriDoc ast briDoc = do
|
|||
-- thing properly.
|
||||
, _lstate_indLevels = [0]
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_commentsPrior = extractCommentsPrior filteredAnns
|
||||
, _lstate_commentsPost = extractCommentsPost filteredAnns
|
||||
, _lstate_comments = filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
|
|
@ -118,9 +119,9 @@ layoutBriDoc ast briDoc = do
|
|||
state' <- MultiRWSS.withMultiStateS state
|
||||
$ layoutBriDocM briDoc'
|
||||
|
||||
let remainingComments = Map.elems (_lstate_commentsPrior state')
|
||||
++ Map.elems (_lstate_commentsPost state')
|
||||
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
let remainingComments =
|
||||
extractAllComments =<< Map.elems (_lstate_comments state')
|
||||
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
|
||||
|
||||
return $ ()
|
||||
|
||||
|
|
@ -204,7 +205,7 @@ transformAlts briDoc
|
|||
-- 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 -> BDFAnnotationPost 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
|
||||
|
|
@ -218,7 +219,7 @@ transformAlts briDoc
|
|||
acp :: AltCurPos <- mGet
|
||||
tellDebugMess $ "transformAlts: visiting: " ++ case brDc of
|
||||
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)
|
||||
#endif
|
||||
let reWrap = (,) brDcId
|
||||
|
|
@ -392,8 +393,10 @@ transformAlts briDoc
|
|||
mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
|
||||
bd' <- rec bd
|
||||
return $ reWrap $ BDFAnnotationPrior annKey bd'
|
||||
BDFAnnotationPost annKey bd ->
|
||||
reWrap . BDFAnnotationPost annKey <$> rec 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
|
||||
|
|
@ -536,7 +539,8 @@ getSpacing !bridoc = rec bridoc
|
|||
$ LineModeValid
|
||||
$ VerticalSpacing 999 VerticalSpacingParNone False
|
||||
BDFAnnotationPrior _annKey bd -> rec bd
|
||||
BDFAnnotationPost _annKey bd -> rec bd
|
||||
BDFAnnotationKW _annKey _kw bd -> rec bd
|
||||
BDFAnnotationRest _annKey bd -> rec bd
|
||||
BDFLines [] -> return
|
||||
$ LineModeValid
|
||||
$ VerticalSpacing 0 VerticalSpacingParNone False
|
||||
|
|
@ -725,7 +729,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
return $ [] -- yes, we just assume that we cannot properly layout
|
||||
-- this.
|
||||
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 ls@(_:_) -> do
|
||||
-- we simply assume that lines is only used "properly", i.e. in
|
||||
|
|
@ -784,7 +789,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
#if INSERTTRACESGETSPACING
|
||||
case brdc of
|
||||
BDFAnnotationPrior{} -> return ()
|
||||
BDFAnnotationPost{} -> return ()
|
||||
BDFAnnotationRest{} -> return ()
|
||||
_ -> mTell $ Seq.fromList ["getSpacing: visiting: "
|
||||
++ 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
|
||||
-- the push/pop cases would need to be copied over
|
||||
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
|
||||
-- prior floating in
|
||||
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
|
||||
|
|
@ -893,6 +883,36 @@ transformSimplifyFloating = stepBO .> stepFull
|
|||
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)
|
||||
|
|
@ -931,8 +951,10 @@ transformSimplifyFloating = stepBO .> stepFull
|
|||
Just $ BDPar (mergeIndents ind1 ind2) line indented
|
||||
BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
|
||||
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
|
||||
BDAddBaseY ind (BDAnnotationPost annKey1 x) ->
|
||||
Just $ BDAnnotationPost 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{} ->
|
||||
|
|
@ -950,7 +972,8 @@ transformSimplifyFloating = stepBO .> stepFull
|
|||
where
|
||||
f = \case
|
||||
x@BDAnnotationPrior{} -> descendPrior x
|
||||
x@BDAnnotationPost{} -> descendPost x
|
||||
x@BDAnnotationKW{} -> descendKW x
|
||||
x@BDAnnotationRest{} -> descendRest x
|
||||
x@BDAddBaseY{} -> descendAddB x
|
||||
x@BDBaseYPushCur{} -> descendBYPush x
|
||||
x@BDBaseYPop{} -> descendBYPop x
|
||||
|
|
@ -995,14 +1018,14 @@ transformSimplifyFloating = stepBO .> stepFull
|
|||
-- BDEnsureIndent indent (BDLines lines) ->
|
||||
-- Just $ BDLines $ BDEnsureIndent indent <$> lines
|
||||
-- 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]
|
||||
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
|
||||
|
||||
transformSimplifyPar :: BriDoc -> BriDoc
|
||||
|
|
@ -1068,12 +1091,18 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
|
|||
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
|
||||
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)
|
||||
-- post floating in
|
||||
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]
|
||||
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.
|
||||
|
|
@ -1145,7 +1174,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
|
|||
BDExternal{} -> Nothing
|
||||
BDLines{} -> Nothing
|
||||
BDAnnotationPrior{} -> Nothing
|
||||
BDAnnotationPost{} -> Nothing
|
||||
BDAnnotationKW{} -> Nothing
|
||||
BDAnnotationRest{} -> Nothing
|
||||
BDEnsureIndent{} -> Nothing
|
||||
BDProhibitMTEL{} -> Nothing
|
||||
BDSetParSpacing{} -> Nothing
|
||||
|
|
@ -1173,10 +1203,12 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
|
|||
Just $ BDLines $ filter isNotEmpty $ lines >>= \case
|
||||
BDLines l -> l
|
||||
x -> [x]
|
||||
BDAddBaseY i (BDAnnotationPost k x) ->
|
||||
Just $ BDAnnotationPost k (BDAddBaseY i x)
|
||||
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) ->
|
||||
|
|
@ -1210,7 +1242,8 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
|
|||
BDForwardLineMode bd -> rec bd
|
||||
BDExternal _ _ _ t -> return $ Text.length t
|
||||
BDAnnotationPrior _ bd -> rec bd
|
||||
BDAnnotationPost _ bd -> rec bd
|
||||
BDAnnotationKW _ _ bd -> rec bd
|
||||
BDAnnotationRest _ bd -> rec bd
|
||||
BDLines (l:_) -> rec l
|
||||
BDLines [] -> error "briDocLineLength BDLines []"
|
||||
BDEnsureIndent _ bd -> rec bd
|
||||
|
|
@ -1305,20 +1338,20 @@ layoutBriDocM = \case
|
|||
state <- mGet
|
||||
let filterF k _ = not $ k `Set.member` subKeys
|
||||
mSet $ state
|
||||
{ _lstate_commentsPrior = Map.filterWithKey filterF
|
||||
$ _lstate_commentsPrior state
|
||||
, _lstate_commentsPost = Map.filterWithKey filterF
|
||||
$ _lstate_commentsPost state
|
||||
{ _lstate_comments = Map.filterWithKey filterF
|
||||
$ _lstate_comments state
|
||||
}
|
||||
BDAnnotationPrior annKey bd -> do
|
||||
do
|
||||
state <- mGet
|
||||
let m = _lstate_commentsPrior state
|
||||
let m = _lstate_comments state
|
||||
let allowMTEL = not (_lstate_inhibitMTEL state)
|
||||
&& Data.Either.isRight (_lstate_curYOrAddNewline state)
|
||||
mAnn <- do
|
||||
let mAnn = Map.lookup annKey m
|
||||
mSet $ state { _lstate_commentsPrior = Map.delete annKey m }
|
||||
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
|
||||
|
|
@ -1339,19 +1372,60 @@ layoutBriDocM = \case
|
|||
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
||||
when allowMTEL $ moveToExactAnn annKey
|
||||
layoutBriDocM bd
|
||||
BDAnnotationPost annKey bd -> do
|
||||
BDAnnotationKW annKey keyword bd -> do
|
||||
layoutBriDocM bd
|
||||
do
|
||||
mAnn <- do
|
||||
state <- mGet
|
||||
let m = _lstate_commentsPost state
|
||||
let mAnn = Map.lookup annKey m
|
||||
mSet $ state { _lstate_commentsPost = Map.delete annKey m }
|
||||
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
|
||||
case mAnn of
|
||||
Nothing -> return ()
|
||||
Just posts -> do
|
||||
posts `forM_` \( ExactPrint.Types.Comment comment _ _
|
||||
forM_ mAnn $ mapM_ $ \( ExactPrint.Types.Comment comment _ _
|
||||
, ExactPrint.Types.DP (y, x)
|
||||
) -> do
|
||||
-- evil hack for CPP:
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ module Language.Haskell.Brittany.ExactPrintUtils
|
|||
( parseModule
|
||||
, parseModuleFromString
|
||||
, commentAnnFixTransform
|
||||
, commentAnnFixTransformGlob
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -54,6 +55,9 @@ 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
|
||||
|
||||
|
||||
|
||||
|
|
@ -114,16 +118,67 @@ parseModuleFromString args fp str =
|
|||
|
||||
-----------
|
||||
|
||||
-- data LNode = forall a . LNode (Located a)
|
||||
--
|
||||
-- commentAnnFixTransformGlob :: GHC.ParsedSource -> ExactPrint.Transform ()
|
||||
-- commentAnnFixTransformGlob modul = do
|
||||
-- let extract :: forall a . SYB.Data a => a -> Seq LNode
|
||||
-- extract = const Seq.empty `SYB.ext1Q` (Seq.singleton . LNode)
|
||||
-- let nodes = SYB.everything (<>) extract modul
|
||||
-- let comp = _
|
||||
-- let sorted = Seq.sortBy (comparing _) nodes
|
||||
-- _
|
||||
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
|
||||
commentAnnFixTransformGlob ast = do
|
||||
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
|
||||
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
|
||||
const Seq.empty `SYB.ext2Q` (\(L a b) -> f1 a b)
|
||||
where
|
||||
f1 b c = (const Seq.empty `SYB.extQ` f2 c) b
|
||||
f2 c l = Seq.singleton (l, ExactPrint.mkAnnKey (L l c))
|
||||
-- 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 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 ()
|
||||
moveTrailingComments astFrom astTo = do
|
||||
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
|
||||
k2 = ExactPrint.mkAnnKey astTo
|
||||
moveComments ans = ans'
|
||||
|
|
@ -158,7 +205,7 @@ moveTrailingComments astFrom astTo = do
|
|||
an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
|
||||
cs1f = ExactPrint.annFollowingComments an1
|
||||
cs2f = ExactPrint.annFollowingComments an2
|
||||
(comments, nonComments) = flip breakHet (ExactPrint.annsDP an1)
|
||||
(comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)
|
||||
$ \case
|
||||
(ExactPrint.AnnComment com, dp) -> Left (com, dp)
|
||||
x -> Right x
|
||||
|
|
|
|||
|
|
@ -37,8 +37,7 @@ module Language.Haskell.Brittany.LayoutBasics
|
|||
, layoutWritePriorComments
|
||||
, layoutWritePostComments
|
||||
, layoutRemoveIndentLevelLinger
|
||||
, extractCommentsPrior
|
||||
, extractCommentsPost
|
||||
, extractAllComments
|
||||
, filterAnns
|
||||
, ppmMoveToExactLoc
|
||||
, docEmpty
|
||||
|
|
@ -48,10 +47,10 @@ module Language.Haskell.Brittany.LayoutBasics
|
|||
, docCols
|
||||
, docSeq
|
||||
, docPar
|
||||
, docPostComment
|
||||
, docNodeAnnKW
|
||||
, docWrapNode
|
||||
, docWrapNodePrior
|
||||
, docWrapNodePost
|
||||
, docWrapNodeRest
|
||||
, docForceSingleline
|
||||
, docForceMultiline
|
||||
, docEnsureIndent
|
||||
|
|
@ -60,7 +59,8 @@ module Language.Haskell.Brittany.LayoutBasics
|
|||
, docSetIndentLevel
|
||||
, docSeparator
|
||||
, docAnnotationPrior
|
||||
, docAnnotationPost
|
||||
, docAnnotationKW
|
||||
, docAnnotationRest
|
||||
, docNonBottomSpacing
|
||||
, docSetParSpacing
|
||||
, docForceParSpacing
|
||||
|
|
@ -86,9 +86,10 @@ where
|
|||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||
import 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
|
||||
|
||||
|
|
@ -639,9 +640,12 @@ layoutWritePriorComments ast = do
|
|||
mAnn <- do
|
||||
state <- mGet
|
||||
let key = ExactPrint.Types.mkAnnKey ast
|
||||
let m = _lstate_commentsPrior state
|
||||
let mAnn = Map.lookup key m
|
||||
mSet $ state { _lstate_commentsPrior = Map.delete key m }
|
||||
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)
|
||||
|
|
@ -669,9 +673,14 @@ layoutWritePostComments ast = do
|
|||
mAnn <- do
|
||||
state <- mGet
|
||||
let key = ExactPrint.Types.mkAnnKey ast
|
||||
let m = _lstate_commentsPost state
|
||||
let mAnn = Map.lookup key m
|
||||
mSet $ state { _lstate_commentsPost = Map.delete key m }
|
||||
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)
|
||||
|
|
@ -725,30 +734,26 @@ layoutIndentRestorePostComment = do
|
|||
-- layoutWritePostComments x
|
||||
-- layoutIndentRestorePostComment
|
||||
|
||||
extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap
|
||||
extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann ->
|
||||
[r | let r = ExactPrint.Types.annPriorComments ann, not (null r)]
|
||||
extractCommentsPost :: ExactPrint.Types.Anns -> PostMap
|
||||
extractCommentsPost anns = flip Map.mapMaybe anns $ \ann ->
|
||||
[ r
|
||||
| let annDPs = ExactPrint.Types.annsDP ann >>= \case
|
||||
(ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)]
|
||||
extractAllComments
|
||||
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
|
||||
extractAllComments ann =
|
||||
ExactPrint.annPriorComments ann
|
||||
++ ExactPrint.annFollowingComments ann
|
||||
++ (ExactPrint.annsDP ann >>= \case
|
||||
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
|
||||
_ -> []
|
||||
, let following = ExactPrint.Types.annFollowingComments ann
|
||||
, let r = following ++ annDPs
|
||||
, not (null r)
|
||||
]
|
||||
)
|
||||
|
||||
|
||||
foldedAnnKeys :: Data.Data.Data ast
|
||||
=> ast
|
||||
-> Set ExactPrint.Types.AnnKey
|
||||
-> Set ExactPrint.AnnKey
|
||||
foldedAnnKeys ast = everything
|
||||
Set.union
|
||||
(\x -> maybe
|
||||
Set.empty
|
||||
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)
|
||||
, l <- gmapQi 0 cast x
|
||||
]
|
||||
|
|
@ -759,8 +764,8 @@ foldedAnnKeys ast = everything
|
|||
|
||||
filterAnns :: Data.Data.Data ast
|
||||
=> ast
|
||||
-> ExactPrint.Types.Anns
|
||||
-> ExactPrint.Types.Anns
|
||||
-> ExactPrint.Anns
|
||||
-> ExactPrint.Anns
|
||||
filterAnns ast anns =
|
||||
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns
|
||||
|
||||
|
|
@ -927,11 +932,17 @@ docSetIndentLevel bdm = do
|
|||
docSeparator :: ToBriDocM BriDocNumbered
|
||||
docSeparator = allocateNode BDFSeparator
|
||||
|
||||
docAnnotationPrior :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
docAnnotationPrior
|
||||
:: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
|
||||
|
||||
docAnnotationPost :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm
|
||||
docAnnotationKW
|
||||
:: 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 bdm = allocateNode . BDFNonBottomSpacing =<< bdm
|
||||
|
|
@ -954,29 +965,14 @@ docCommaSep = appSep $ docLit $ Text.pack ","
|
|||
docParenLSep :: ToBriDocM BriDocNumbered
|
||||
docParenLSep = appSep $ docLit $ Text.pack "("
|
||||
|
||||
|
||||
docPostComment :: (Data.Data.Data ast)
|
||||
docNodeAnnKW
|
||||
:: Data.Data.Data ast
|
||||
=> GenLocated SrcSpan ast
|
||||
-> Maybe AnnKeywordId
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
docPostComment ast bdm = do
|
||||
bd <- bdm
|
||||
allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd
|
||||
|
||||
-- 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
|
||||
docNodeAnnKW ast kw bdm =
|
||||
docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm
|
||||
|
||||
class DocWrapable a where
|
||||
docWrapNode :: ( Data.Data.Data ast)
|
||||
|
|
@ -987,7 +983,7 @@ class DocWrapable a where
|
|||
=> GenLocated SrcSpan ast
|
||||
-> ToBriDocM a
|
||||
-> ToBriDocM a
|
||||
docWrapNodePost :: ( Data.Data.Data ast)
|
||||
docWrapNodeRest :: ( Data.Data.Data ast)
|
||||
=> GenLocated SrcSpan ast
|
||||
-> ToBriDocM a
|
||||
-> ToBriDocM a
|
||||
|
|
@ -1001,7 +997,7 @@ instance DocWrapable BriDocNumbered where
|
|||
$ (,) i1
|
||||
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
|
||||
$ (,) i2
|
||||
$ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
|
||||
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
|
||||
$ bd
|
||||
docWrapNodePrior ast bdm = do
|
||||
bd <- bdm
|
||||
|
|
@ -1010,12 +1006,12 @@ instance DocWrapable BriDocNumbered where
|
|||
$ (,) i1
|
||||
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
|
||||
$ bd
|
||||
docWrapNodePost ast bdm = do
|
||||
docWrapNodeRest ast bdm = do
|
||||
bd <- bdm
|
||||
i2 <- allocNodeIndex
|
||||
return
|
||||
$ (,) i2
|
||||
$ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
|
||||
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
|
||||
$ bd
|
||||
|
||||
instance DocWrapable a => DocWrapable [a] where
|
||||
|
|
@ -1028,7 +1024,7 @@ instance DocWrapable a => DocWrapable [a] where
|
|||
return [bd']
|
||||
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> do
|
||||
bd1' <- docWrapNodePrior ast (return bd1)
|
||||
bdN' <- docWrapNodePost ast (return bdN)
|
||||
bdN' <- docWrapNodeRest ast (return bdN)
|
||||
return $ [bd1'] ++ reverse bdM ++ [bdN']
|
||||
_ -> error "cannot happen (TM)"
|
||||
docWrapNodePrior ast bdsm = do
|
||||
|
|
@ -1038,12 +1034,12 @@ instance DocWrapable a => DocWrapable [a] where
|
|||
(bd1:bdR) -> do
|
||||
bd1' <- docWrapNodePrior ast (return bd1)
|
||||
return $ (bd1':bdR)
|
||||
docWrapNodePost ast bdsm = do
|
||||
docWrapNodeRest ast bdsm = do
|
||||
bds <- bdsm
|
||||
case reverse bds of
|
||||
[] -> return $ []
|
||||
(bdN:bdR) -> do
|
||||
bdN' <- docWrapNodePost ast (return bdN)
|
||||
bdN' <- docWrapNodeRest ast (return bdN)
|
||||
return $ reverse $ (bdN':bdR)
|
||||
|
||||
instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
|
||||
|
|
@ -1055,15 +1051,15 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
|
|||
return $ (bds, bd', x)
|
||||
else do
|
||||
bds' <- docWrapNodePrior ast (return bds)
|
||||
bd' <- docWrapNodePost ast (return bd)
|
||||
bd' <- docWrapNodeRest ast (return bd)
|
||||
return $ (bds', bd', x)
|
||||
docWrapNodePrior ast stuffM = do
|
||||
(bds, bd, x) <- stuffM
|
||||
bds' <- docWrapNodePrior ast (return bds)
|
||||
return $ (bds', bd, x)
|
||||
docWrapNodePost ast stuffM = do
|
||||
docWrapNodeRest ast stuffM = do
|
||||
(bds, bd, x) <- stuffM
|
||||
bd' <- docWrapNodePost ast (return bd)
|
||||
bd' <- docWrapNodeRest ast (return bd)
|
||||
return $ (bds, bd', x)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -44,13 +44,13 @@ layoutSig lsig@(L _loc sig) = docWrapNode lsig $ case sig of
|
|||
typeDoc <- docSharedWrapper layoutType typ
|
||||
docAlt
|
||||
[ docSeq
|
||||
[ appSep $ docPostComment lsig $ docLit nameStr
|
||||
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
|
||||
, appSep $ docLit $ Text.pack "::"
|
||||
, docForceSingleline typeDoc
|
||||
]
|
||||
, docAddBaseY BrIndentRegular
|
||||
$ docPar
|
||||
(docPostComment lsig $ docLit nameStr)
|
||||
(docWrapNodeRest lsig $ docLit nameStr)
|
||||
( docCols ColTyOpPrefix
|
||||
[ docLit $ Text.pack ":: "
|
||||
, docAddBaseY (BrIndentSpecial 3) $ typeDoc
|
||||
|
|
@ -139,7 +139,7 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs
|
|||
: (spacifyDocs $ docForceSingleline <$> ps)
|
||||
(Nothing, ps) -> docCols ColPatterns
|
||||
$ (List.intersperse docSeparator $ docForceSingleline <$> ps)
|
||||
clauseDocs <- docWrapNodePost lmatch $ layoutGrhs `mapM` grhss
|
||||
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
|
||||
mWhereDocs <- layoutLocalBinds whereBinds
|
||||
layoutPatternBindFinal binderDoc (Just patDoc) clauseDocs mWhereDocs
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import Language.Haskell.Brittany.Types
|
|||
import Language.Haskell.Brittany.LayoutBasics
|
||||
|
||||
import RdrName ( RdrName(..) )
|
||||
import GHC ( runGhc, GenLocated(L), moduleNameString )
|
||||
import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )
|
||||
import SrcLoc ( SrcSpan )
|
||||
import HsSyn
|
||||
import Name
|
||||
|
|
@ -467,9 +467,12 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
|
|||
briDocByExact lexpr
|
||||
RecordCon lname _ _ (HsRecFields [] Nothing) -> do
|
||||
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
|
||||
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
|
||||
fExpDoc <- if pun
|
||||
then return Nothing
|
||||
|
|
@ -479,15 +482,15 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
|
|||
[ docSetParSpacing
|
||||
$ docAddBaseY BrIndentRegular
|
||||
$ docPar
|
||||
(docLit t)
|
||||
(docNodeAnnKW lexpr Nothing $ nameDoc)
|
||||
(docNonBottomSpacing $ docLines $ let
|
||||
line1 = docCols ColRecUpdate
|
||||
[ appSep $ docLit $ Text.pack "{"
|
||||
, appSep $ docLit $ fd1n
|
||||
, docWrapNodePrior fd1l $ appSep $ docLit $ fd1n
|
||||
, case fd1e of
|
||||
Just x -> docSeq
|
||||
[ appSep $ docLit $ Text.pack "="
|
||||
, docWrapNode fd1l $ docAddBaseY BrIndentRegular $ x
|
||||
, docWrapNodeRest fd1l $ docAddBaseY BrIndentRegular $ x
|
||||
]
|
||||
Nothing -> docEmpty
|
||||
]
|
||||
|
|
@ -495,9 +498,9 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
|
|||
[ appSep $ docLit $ Text.pack ","
|
||||
, appSep $ docLit $ fText
|
||||
, case fDoc of
|
||||
Just x -> docSeq
|
||||
Just x -> docWrapNode lfield $ docSeq
|
||||
[ appSep $ docLit $ Text.pack "="
|
||||
, docWrapNode lfield $ docAddBaseY BrIndentRegular x
|
||||
, docAddBaseY BrIndentRegular x
|
||||
]
|
||||
Nothing -> docEmpty
|
||||
]
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
forallDoc
|
||||
( docLines
|
||||
[ docCols ColTyOpPrefix
|
||||
[ docPostComment ltype $ docLit $ Text.pack " . "
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
|
||||
, docAddBaseY (BrIndentSpecial 3)
|
||||
$ docForceSingleline contextDoc
|
||||
]
|
||||
|
|
@ -153,7 +153,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
, docPar
|
||||
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
|
||||
( docCols ColTyOpPrefix
|
||||
[ docPostComment ltype $ docLit $ Text.pack ". "
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack ". "
|
||||
, return typeDoc
|
||||
]
|
||||
)
|
||||
|
|
@ -176,7 +176,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
]
|
||||
)
|
||||
++[ docCols ColTyOpPrefix
|
||||
[ docPostComment ltype $ docLit $ Text.pack ". "
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack ". "
|
||||
, return typeDoc
|
||||
]
|
||||
]
|
||||
|
|
@ -239,13 +239,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
docAlt
|
||||
[ docSeq
|
||||
[ docForceSingleline typeDoc1
|
||||
, docPostComment ltype $ appSep $ docLit $ Text.pack " ->"
|
||||
, docWrapNodeRest ltype $ appSep $ docLit $ Text.pack " ->"
|
||||
, docForceSingleline typeDoc2
|
||||
]
|
||||
, docPar
|
||||
typeDoc1
|
||||
( docCols ColTyOpPrefix
|
||||
[ docPostComment ltype $ appSep $ docLit $ Text.pack "->"
|
||||
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
|
||||
, docAddBaseY (BrIndentSpecial 3)
|
||||
$ if shouldForceML then docForceMultiline typeDoc2
|
||||
else typeDoc2
|
||||
|
|
@ -256,13 +256,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
typeDoc1 <- docSharedWrapper layoutType typ1
|
||||
docAlt
|
||||
[ docSeq
|
||||
[ docPostComment ltype $ docLit $ Text.pack "("
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack "("
|
||||
, docForceSingleline typeDoc1
|
||||
, docLit $ Text.pack ")"
|
||||
]
|
||||
, docPar
|
||||
( docCols ColTyOpPrefix
|
||||
[ docPostComment ltype $ docParenLSep
|
||||
[ docWrapNodeRest ltype $ docParenLSep
|
||||
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
|
||||
])
|
||||
(docLit $ Text.pack ")")
|
||||
|
|
@ -322,13 +322,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
typeDoc1 <- docSharedWrapper layoutType typ1
|
||||
docAlt
|
||||
[ docSeq
|
||||
[ docPostComment ltype $ docLit $ Text.pack "["
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack "["
|
||||
, docForceSingleline typeDoc1
|
||||
, docLit $ Text.pack "]"
|
||||
]
|
||||
, docPar
|
||||
( docCols ColTyOpPrefix
|
||||
[ docPostComment ltype $ docLit $ Text.pack "[ "
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
|
||||
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
|
||||
])
|
||||
(docLit $ Text.pack "]")
|
||||
|
|
@ -337,13 +337,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
typeDoc1 <- docSharedWrapper layoutType typ1
|
||||
docAlt
|
||||
[ docSeq
|
||||
[ docPostComment ltype $ docLit $ Text.pack "[:"
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack "[:"
|
||||
, docForceSingleline typeDoc1
|
||||
, docLit $ Text.pack ":]"
|
||||
]
|
||||
, docPar
|
||||
( docCols ColTyOpPrefix
|
||||
[ docPostComment ltype $ docLit $ Text.pack "[:"
|
||||
[ docWrapNodeRest ltype $ docLit $ Text.pack "[:"
|
||||
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
|
||||
])
|
||||
(docLit $ Text.pack ":]")
|
||||
|
|
@ -451,7 +451,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
typeDoc1 <- docSharedWrapper layoutType typ1
|
||||
docAlt
|
||||
[ docSeq
|
||||
[ docPostComment ltype
|
||||
[ docWrapNodeRest ltype
|
||||
$ docLit
|
||||
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
|
||||
, docForceSingleline typeDoc1
|
||||
|
|
@ -461,7 +461,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
|
||||
)
|
||||
(docCols ColTyOpPrefix
|
||||
[ docPostComment ltype
|
||||
[ docWrapNodeRest ltype
|
||||
$ docLit $ Text.pack "::"
|
||||
, docAddBaseY (BrIndentSpecial 2) typeDoc1
|
||||
])
|
||||
|
|
@ -472,14 +472,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
docAlt
|
||||
[ docSeq
|
||||
[ docForceSingleline typeDoc1
|
||||
, docPostComment ltype
|
||||
, docWrapNodeRest ltype
|
||||
$ docLit $ Text.pack " ~ "
|
||||
, docForceSingleline typeDoc2
|
||||
]
|
||||
, docPar
|
||||
typeDoc1
|
||||
( docCols ColTyOpPrefix
|
||||
[ docPostComment ltype
|
||||
[ docWrapNodeRest ltype
|
||||
$ docLit $ Text.pack "~ "
|
||||
, docAddBaseY (BrIndentSpecial 2) typeDoc2
|
||||
])
|
||||
|
|
@ -497,7 +497,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
, docPar
|
||||
typeDoc1
|
||||
( docCols ColTyOpPrefix
|
||||
[ docPostComment ltype
|
||||
[ docWrapNodeRest ltype
|
||||
$ docLit $ Text.pack ":: "
|
||||
, docAddBaseY (BrIndentSpecial 3) kindDoc1
|
||||
])
|
||||
|
|
|
|||
|
|
@ -17,11 +17,11 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
|||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
|
||||
import RdrName ( RdrName(..) )
|
||||
import GHC ( runGhc, GenLocated(L), moduleNameString )
|
||||
import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId )
|
||||
import SrcLoc ( SrcSpan )
|
||||
|
||||
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
|
||||
|
||||
|
|
@ -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 PriorMap = Map AnnKey [(Comment, DeltaPos)]
|
||||
type PostMap = Map AnnKey [(Comment, DeltaPos)]
|
||||
|
||||
data LayoutState = LayoutState
|
||||
{ _lstate_baseYs :: [Int]
|
||||
-- ^ stack of number of current indentation columns
|
||||
|
|
@ -56,10 +53,7 @@ data LayoutState = LayoutState
|
|||
-- on the first indented element have an
|
||||
-- annotation offset relative to the last
|
||||
-- non-indented element, which is confusing.
|
||||
, _lstate_commentsPrior :: PriorMap -- map of "true" pre-node comments that
|
||||
-- really _should_ be included in the
|
||||
-- output.
|
||||
, _lstate_commentsPost :: PostMap -- similarly, for post-node comments.
|
||||
, _lstate_comments :: Anns
|
||||
, _lstate_commentCol :: Maybe Int -- this communicates two things:
|
||||
-- firstly, that cursor is currently
|
||||
-- at the end of a comment (so needs
|
||||
|
|
@ -221,7 +215,8 @@ data BriDoc
|
|||
Bool -- should print extra comment ?
|
||||
Text
|
||||
| BDAnnotationPrior AnnKey BriDoc
|
||||
| BDAnnotationPost AnnKey BriDoc
|
||||
| BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc
|
||||
| BDAnnotationRest AnnKey BriDoc
|
||||
| BDLines [BriDoc]
|
||||
| BDEnsureIndent BrIndent BriDoc
|
||||
-- the following constructors are only relevant for the alt transformation
|
||||
|
|
@ -270,7 +265,8 @@ data BriDocF f
|
|||
Bool -- should print extra comment ?
|
||||
Text
|
||||
| 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))]
|
||||
| BDFEnsureIndent BrIndent (f (BriDocF f))
|
||||
| BDFForceMultiline (f (BriDocF f))
|
||||
|
|
@ -307,7 +303,8 @@ instance Uniplate.Uniplate BriDoc where
|
|||
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd
|
||||
uniplate x@BDExternal{} = plate x
|
||||
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 (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd
|
||||
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
|
||||
|
|
@ -337,7 +334,8 @@ unwrapBriDocNumbered tpl = case snd tpl of
|
|||
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
|
||||
BDFExternal k ks c t -> BDExternal k ks c t
|
||||
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
|
||||
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
|
||||
BDFForceMultiline bd -> BDForceMultiline $ rec bd
|
||||
|
|
@ -367,7 +365,8 @@ briDocSeqSpine = \case
|
|||
BDForwardLineMode bd -> briDocSeqSpine bd
|
||||
BDExternal{} -> ()
|
||||
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
|
||||
BDEnsureIndent _ind bd -> briDocSeqSpine bd
|
||||
BDForceMultiline bd -> briDocSeqSpine bd
|
||||
|
|
|
|||
|
|
@ -17,6 +17,8 @@ module Language.Haskell.Brittany.Utils
|
|||
, tellDebugMess
|
||||
, tellDebugMessShow
|
||||
, briDocToDocWithAnns
|
||||
, breakEither
|
||||
, spanMaybe
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -228,7 +230,8 @@ briDocToDoc = astToDoc . removeAnnotations
|
|||
where
|
||||
removeAnnotations = Uniplate.transform $ \case
|
||||
BDAnnotationPrior _ x -> x
|
||||
BDAnnotationPost _ x -> x
|
||||
BDAnnotationKW _ _ x -> x
|
||||
BDAnnotationRest _ x -> x
|
||||
x -> x
|
||||
|
||||
briDocToDocWithAnns :: BriDoc -> PP.Doc
|
||||
|
|
@ -236,3 +239,17 @@ briDocToDocWithAnns = astToDoc
|
|||
|
||||
annsDoc :: ExactPrint.Types.Anns -> PP.Doc
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -373,7 +373,7 @@ import qualified Data.Bool as Bool
|
|||
-- import qualified Data.Complex as Complex
|
||||
-- import qualified Data.Either as Either
|
||||
-- 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.Functor.Identity as Identity
|
||||
-- import qualified Data.IORef as IORef
|
||||
|
|
|
|||
Loading…
Reference in New Issue