From 5166b3dd9e07efadf154ad3441162e2807735444 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 11 Aug 2016 13:31:13 +0200 Subject: [PATCH] Improve comment handling (Add KW node; annotation transform) --- src/Language/Haskell/Brittany.hs | 28 +- src/Language/Haskell/Brittany/BriLayouter.hs | 270 +++++++++++------- .../Haskell/Brittany/ExactPrintUtils.hs | 85 ++++-- src/Language/Haskell/Brittany/LayoutBasics.hs | 130 ++++----- .../Haskell/Brittany/Layouters/Decl.hs | 6 +- .../Haskell/Brittany/Layouters/Expr.hs | 19 +- .../Haskell/Brittany/Layouters/Type.hs | 32 +-- src/Language/Haskell/Brittany/Types.hs | 27 +- src/Language/Haskell/Brittany/Utils.hs | 19 +- srcinc/prelude.inc | 2 +- 10 files changed, 384 insertions(+), 234 deletions(-) diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 2a846c1..2fcac56 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -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) diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index 7508ceb..e4d8fd2 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -99,6 +99,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] @@ -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,64 +1338,105 @@ 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_comments state + let allowMTEL = not (_lstate_inhibitMTEL state) + && Data.Either.isRight (_lstate_curYOrAddNewline state) + mAnn <- do + let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) annKey m + } + return mAnn + case mAnn of + Nothing -> when allowMTEL $ moveToExactAnn annKey + Just [] -> when allowMTEL $ moveToExactAnn annKey + Just priors -> do + -- layoutResetSepSpace + priors `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (y, x) + ) -> do + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) + _ -> layoutMoveToCommentPos y x + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline $ Text.pack $ comment + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + when allowMTEL $ moveToExactAnn annKey + layoutBriDocM bd + BDAnnotationKW annKey keyword bd -> do + layoutBriDocM bd + mAnn <- do state <- mGet - let m = _lstate_commentsPrior 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 } - 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 _ _ + 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 } - when allowMTEL $ moveToExactAnn annKey + -- 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 - BDAnnotationPost annKey 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 } - return mAnn - case mAnn of - Nothing -> return () - Just posts -> do - posts `forM_` \( ExactPrint.Types.Comment comment _ _ + mAnn <- do + state <- mGet + let m = _lstate_comments state + let mAnn = extractAllComments <$> Map.lookup annKey m + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = [] + } + ) + annKey + m + } + return mAnn + forM_ mAnn $ mapM_ $ \( ExactPrint.Types.Comment comment _ _ , ExactPrint.Types.DP (y, x) ) -> do - -- evil hack for CPP: - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) - _ -> layoutMoveToCommentPos y x - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline $ Text.pack $ comment - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) + _ -> layoutMoveToCommentPos y x + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline $ Text.pack $ comment + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd diff --git a/src/Language/Haskell/Brittany/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/ExactPrintUtils.hs index 9ae6216..31d2bc7 100644 --- a/src/Language/Haskell/Brittany/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/ExactPrintUtils.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index d170580..03ee920 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -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 @@ -638,10 +639,13 @@ layoutWritePriorComments :: (Data.Data.Data ast, 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 key = ExactPrint.Types.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns + } return mAnn #if INSERTTRACES tellDebugMessShow ("layoutWritePriorComments", ExactPrint.Types.mkAnnKey ast, mAnn) @@ -668,10 +672,15 @@ layoutWritePostComments :: (Data.Data.Data ast, 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 key = ExactPrint.Types.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns + } return mAnn #if INSERTTRACES tellDebugMessShow ("layoutWritePostComments", ExactPrint.Types.mkAnnKey ast, mAnn) @@ -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)] - _ -> [] - , let following = ExactPrint.Types.annFollowingComments ann - , let r = following ++ annDPs - , not (null r) - ] +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)] + _ -> [] + ) 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) - => GenLocated SrcSpan ast - -> 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 + :: Data.Data.Data ast + => GenLocated SrcSpan ast + -> Maybe AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +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) diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index da87b9a..f69a4e7 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index a4562cf..4846743 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs @@ -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 ] diff --git a/src/Language/Haskell/Brittany/Layouters/Type.hs b/src/Language/Haskell/Brittany/Layouters/Type.hs index 8c4e36b..7c36c04 100644 --- a/src/Language/Haskell/Brittany/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Layouters/Type.hs @@ -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 ]) diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index f82ec9f..19f9ca5 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Utils.hs b/src/Language/Haskell/Brittany/Utils.hs index 574518c..a08cf80 100644 --- a/src/Language/Haskell/Brittany/Utils.hs +++ b/src/Language/Haskell/Brittany/Utils.hs @@ -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) diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc index 61910b1..bd42f2a 100644 --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -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