From a3ae082f296d9bfd4197de54165f52ec0fe1add1 Mon Sep 17 00:00:00 2001 From: mrkun Date: Mon, 14 Feb 2022 16:28:01 +0300 Subject: [PATCH] Hack on Internal (incomplete) --- .../Language/Haskell/Brittany/Internal.hs | 142 +++++++++--------- .../Haskell/Brittany/Internal/EPCompat.hs | 2 +- .../Brittany/Internal/ExactPrintUtils.hs | 25 ++- 3 files changed, 86 insertions(+), 83 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 06cbb63..04985d0 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -57,7 +57,7 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified UI.Butcher.Monadic as Butcher - +import Language.Haskell.Brittany.Internal.EPCompat as ExactPrint data InlineConfigTarget = InlineConfigTargetModule @@ -73,16 +73,17 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do let commentLiness = [ ( k - , [ x - | (ExactPrint.Comment x _ _, _) <- - (ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ) - ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] + , [] + -- , [ x + -- | (ExactPrint.Comment x _ _, _) <- + -- (ExactPrint.annPriorComments ann + -- ++ ExactPrint.annFollowingComments ann + -- ) + -- ] + -- ++ [ x + -- | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + -- ExactPrint.annsDP ann + -- ] ) | (k, ann) <- Map.toList anns ] @@ -218,11 +219,12 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap -getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = +getTopLevelDeclNameMap (L _ (HsModule _ _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList - [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls - , (name : _) <- [getDeclBindingNames decl] + [ + -- (ExactPrint.mkAnnKey decl, name) + -- | decl <- decls + -- , (name : _) <- [getDeclBindingNames decl] ] @@ -245,7 +247,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do let config_pp = config & _conf_preprocessor let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack - (anns, parsedSource, hasCPP) <- do + ({-anns,-} parsedSource, hasCPP) <- do let hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s @@ -270,7 +272,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do Right x -> pure x (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + $ extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedSource) let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting @@ -285,9 +287,9 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do & _econf_omit_output_valid_check & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource + then return $ pPrintModule moduleConfig perItemConf {-anns-} undefined parsedSource else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource + $ pPrintModuleAndCheck moduleConfig perItemConf {-anns-} undefined parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s @@ -341,7 +343,7 @@ pPrintModule conf inlineConf anns parsedModule = $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ do traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns + $ annsDoc {-anns-} undefined ppModule parsedModule tracer = if Seq.null debugStrings then id @@ -389,9 +391,9 @@ parsePrintModuleTests conf filename input = do inputStr case parseResult of Left err -> return $ Left err - Right (anns, parsedModule, _) -> runExceptT $ do + Right ({-anns,-} parsedModule, _) -> runExceptT $ do (inlineConf, perItemConf) <- - case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + case extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedModule) of Left err -> throwE $ "error in inline config: " ++ show err Right x -> pure x let moduleConf = cZipWith fromOptionIdentity conf inlineConf @@ -402,9 +404,9 @@ parsePrintModuleTests conf filename input = do .> _econf_omit_output_valid_check .> confUnpack (errs, ltext) <- if omitCheck - then return $ pPrintModule moduleConf perItemConf anns parsedModule + then return $ pPrintModule moduleConf perItemConf {-anns-} undefined parsedModule else lift - $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule + $ pPrintModuleAndCheck moduleConf perItemConf {-anns-} undefined parsedModule if null errs then pure $ TextL.toStrict $ ltext else @@ -460,18 +462,18 @@ toLocal conf anns m = do pure x ppModule :: GenLocated SrcSpan HsModule -> PPM () -ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do +ppModule lmod@(L _loc _m@(HsModule _ _ _name _exports _ decls _ _)) = do defaultAnns <- do anns <- mAsk - let annKey = ExactPrint.mkAnnKey lmod + let annKey = undefined -- ExactPrint.mkAnnKey lmod let annMap = Map.findWithDefault Map.empty annKey anns - let isEof = (== ExactPrint.AnnEofPos) - let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } - pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap + -- let isEof = (== ExactPrint.AnnEofPos) + -- let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } + pure $ undefined {- fmap (overAnnsDP . filter $ isEof . fst) -} annMap post <- ppPreamble lmod decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl + let declAnnKey = undefined --ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf @@ -484,7 +486,7 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations - $ annsDoc filteredAnns + $ annsDoc {-filteredAnns-} undefined config <- mAsk @@ -505,27 +507,27 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd - let - finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post + -- let + -- finalComments = filter + -- (fst .> \case + -- -- ExactPrint.AnnComment{} -> True + -- _ -> False + -- ) + -- post post `forM_` \case - (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do - ppmMoveToExactLoc l - mTell $ Text.Builder.fromString cmStr - (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let - folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> - ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + -- (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do + -- ppmMoveToExactLoc l + -- mTell $ Text.Builder.fromString cmStr + -- (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> + -- let + -- folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + -- ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> + -- ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + -- , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + -- ) + -- _ -> (acc + y, x) + -- (cmY, cmX) = foldl' folder (0, 0) finalComments + -- in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] @@ -539,10 +541,10 @@ getDeclBindingNames (L _ decl) = case decl of -- This includes the imports ppPreamble :: GenLocated SrcSpan HsModule - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] + -> PPM [{- (ExactPrint.KeywordId, ExactPrint.DeltaPos)-} ((), ())] ppPreamble lmod@(L loc m@HsModule{}) = do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap + Map.findWithDefault Map.empty ({-ExactPrint.mkAnnKey-} undefined lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) -- modules to both HsModule and the elements in the module -- this can cause duplication of comments. So strip @@ -555,14 +557,14 @@ ppPreamble lmod@(L loc m@HsModule{}) = do let (filteredAnns', post) = - case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of + case Map.lookup ({-ExactPrint.mkAnnKey-} undefined lmod) filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> let - modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True + modAnnsDp = undefined -- ExactPrint.annsDP mAnn + -- isWhere (ExactPrint.G AnnWhere) = True isWhere _ = False - isEof (ExactPrint.AnnEofPos) = True + -- isEof (ExactPrint.AnnEofPos) = True isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp @@ -571,9 +573,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.annsDP = pre } + mAnn' = mAnn -- { ExactPrint.annsDP = pre } filteredAnns'' = - Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns + Map.insert ({-ExactPrint.mkAnnKey-} undefined lmod) mAnn' filteredAnns in (filteredAnns'', post') traceIfDumpConf "bridoc annotations filtered/transformed" @@ -582,7 +584,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do if shouldReformatPreamble then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod + briDoc <- briDocMToPPM $ layoutModule (reLocA lmod) layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } @@ -667,16 +669,18 @@ layoutBriDoc briDoc = do state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' let + remainingComments :: [((), ())] remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns + [ + -- c + -- | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + -- (_lstate_comments state') + -- -- With the new import layouter, we manually process comments + -- -- without relying on the backend to consume the comments out of + -- -- the state/map. So they will end up here, and we need to ignore + -- -- them. + -- , ExactPrint.unConName con /= "ImportDecl" + -- , c <- extractAllComments elemAnns ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs index 16d753d..850fce1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs +++ b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs @@ -10,4 +10,4 @@ type Annotation = () type Anns = Map AnnKey () type AnnKey = () -type EPAnns = () +type EPAnns = Map AnnKey () diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 6c4fefc..1f89422 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -182,29 +182,29 @@ commentAnnFixTransformGlob ast = undefined -- ExactPrint.modifyAnnsT moveComments -{-- -- | split a set of annotations in a module into a map from top-level module -- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- implementation would have. extractToplevelAnns :: Located HsModule - -> ExactPrint.Anns - -> Map ExactPrint.AnnKey ExactPrint.Anns + -> Anns + -> Map AnnKey Anns extractToplevelAnns lmod anns = output where - (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod - declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + (L _ (HsModule _ _ _ _ _ ldecls _ _)) = lmod + declMap1 :: Map AnnKey AnnKey declMap1 = Map.unions $ ldecls <&> \ldecl -> - Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) - declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + Map.fromSet (const ({-ExactPrint.mkAnnKey-} undefined ldecl)) (foldedAnnKeys ldecl) + declMap2 :: Map AnnKey AnnKey declMap2 = Map.fromList - $ [ (captured, declMap1 Map.! k) - | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns + $ [ + -- (captured, declMap1 Map.! k) + -- | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns ] declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod + modKey = {-ExactPrint.mkAnnKey-} undefined lmod output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) @@ -215,13 +215,13 @@ groupMap f = Map.foldlWithKey' insert k a Nothing = Just (Map.singleton k a) insert k a (Just m) = Just (Map.insert k a m) -foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey +foldedAnnKeys :: Data.Data.Data ast => ast -> Set AnnKey foldedAnnKeys ast = SYB.everything Set.union (\x -> maybe Set.empty Set.singleton - [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x + [ SYB.gmapQi 1 ({-ExactPrint.mkAnnKey-} undefined . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x ] @@ -232,7 +232,6 @@ foldedAnnKeys ast = SYB.everything ast where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) --} withTransformedAnns :: Data ast