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

Hack on Internal (incomplete)

mxxun/ghc-9.2
mrkun 2022-02-14 16:28:01 +03:00
parent 16a89cdfeb
commit a3ae082f29
3 changed files with 86 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
source/library/Language/Haskell/Brittany/Internal.hs
View File

@ -57,7 +57,7 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified UI.Butcher.Monadic as Butcher import qualified UI.Butcher.Monadic as Butcher
import Language.Haskell.Brittany.Internal.EPCompat as ExactPrint
data InlineConfigTarget data InlineConfigTarget
= InlineConfigTargetModule = InlineConfigTargetModule
@ -73,16 +73,17 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
let let
commentLiness = commentLiness =
[ ( k [ ( k
, [ x , []
| (ExactPrint.Comment x _ _, _) <- -- , [ x
(ExactPrint.annPriorComments ann -- | (ExactPrint.Comment x _ _, _) <-
++ ExactPrint.annFollowingComments ann -- (ExactPrint.annPriorComments ann
) -- ++ ExactPrint.annFollowingComments ann
] -- )
++ [ x -- ]
| (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- -- ++ [ x
ExactPrint.annsDP ann -- | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
] -- ExactPrint.annsDP ann
-- ]
) )
| (k, ann) <- Map.toList anns | (k, ann) <- Map.toList anns
] ]
@ -218,11 +219,12 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = getTopLevelDeclNameMap (L _ (HsModule _ _ _name _exports _ decls _ _)) =
TopLevelDeclNameMap $ Map.fromList TopLevelDeclNameMap $ Map.fromList
[ (ExactPrint.mkAnnKey decl, name) [
| decl <- decls -- (ExactPrint.mkAnnKey decl, name)
, (name : _) <- [getDeclBindingNames decl] -- | decl <- decls
-- , (name : _) <- [getDeclBindingNames decl]
] ]
@ -245,7 +247,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
let config_pp = config & _conf_preprocessor let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
(anns, parsedSource, hasCPP) <- do ({-anns,-} parsedSource, hasCPP) <- do
let let
hackF s = hackF s =
if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else 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 Right x -> pure x
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
either (throwE . (: []) . uncurry ErrorMacroConfig) pure either (throwE . (: []) . uncurry ErrorMacroConfig) pure
$ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) $ extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedSource)
let moduleConfig = cZipWith fromOptionIdentity config inlineConf let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
if disableFormatting if disableFormatting
@ -285,9 +287,9 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
& _econf_omit_output_valid_check & _econf_omit_output_valid_check
& confUnpack & confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConfig perItemConf anns parsedSource then return $ pPrintModule moduleConfig perItemConf {-anns-} undefined parsedSource
else lift else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource $ pPrintModuleAndCheck moduleConfig perItemConf {-anns-} undefined parsedSource
let let
hackF s = fromMaybe s hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
@ -341,7 +343,7 @@ pPrintModule conf inlineConf anns parsedModule =
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
$ do $ do
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns $ annsDoc {-anns-} undefined
ppModule parsedModule ppModule parsedModule
tracer = if Seq.null debugStrings tracer = if Seq.null debugStrings
then id then id
@ -389,9 +391,9 @@ parsePrintModuleTests conf filename input = do
inputStr inputStr
case parseResult of case parseResult of
Left err -> return $ Left err Left err -> return $ Left err
Right (anns, parsedModule, _) -> runExceptT $ do Right ({-anns,-} parsedModule, _) -> runExceptT $ do
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of case extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedModule) of
Left err -> throwE $ "error in inline config: " ++ show err Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x Right x -> pure x
let moduleConf = cZipWith fromOptionIdentity conf inlineConf let moduleConf = cZipWith fromOptionIdentity conf inlineConf
@ -402,9 +404,9 @@ parsePrintModuleTests conf filename input = do
.> _econf_omit_output_valid_check .> _econf_omit_output_valid_check
.> confUnpack .> confUnpack
(errs, ltext) <- if omitCheck (errs, ltext) <- if omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedModule then return $ pPrintModule moduleConf perItemConf {-anns-} undefined parsedModule
else lift else lift
$ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule $ pPrintModuleAndCheck moduleConf perItemConf {-anns-} undefined parsedModule
if null errs if null errs
then pure $ TextL.toStrict $ ltext then pure $ TextL.toStrict $ ltext
else else
@ -460,18 +462,18 @@ toLocal conf anns m = do
pure x pure x
ppModule :: GenLocated SrcSpan HsModule -> PPM () 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 defaultAnns <- do
anns <- mAsk anns <- mAsk
let annKey = ExactPrint.mkAnnKey lmod let annKey = undefined -- ExactPrint.mkAnnKey lmod
let annMap = Map.findWithDefault Map.empty annKey anns let annMap = Map.findWithDefault Map.empty annKey anns
let isEof = (== ExactPrint.AnnEofPos) -- let isEof = (== ExactPrint.AnnEofPos)
let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } -- let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a }
pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap pure $ undefined {- fmap (overAnnsDP . filter $ isEof . fst) -} annMap
post <- ppPreamble lmod post <- ppPreamble lmod
decls `forM_` \decl -> do decls `forM_` \decl -> do
let declAnnKey = ExactPrint.mkAnnKey decl let declAnnKey = undefined --ExactPrint.mkAnnKey decl
let declBindingNames = getDeclBindingNames decl let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
@ -484,7 +486,7 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
traceIfDumpConf traceIfDumpConf
"bridoc annotations filtered/transformed" "bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns $ annsDoc {-filteredAnns-} undefined
config <- mAsk config <- mAsk
@ -505,27 +507,27 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd layoutBriDoc bd
let -- let
finalComments = filter -- finalComments = filter
(fst .> \case -- (fst .> \case
ExactPrint.AnnComment{} -> True -- -- ExactPrint.AnnComment{} -> True
_ -> False -- _ -> False
) -- )
post -- post
post `forM_` \case post `forM_` \case
(ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do -- (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
ppmMoveToExactLoc l -- ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr -- mTell $ Text.Builder.fromString cmStr
(ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> -- (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
let -- let
folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of -- folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> -- ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span -- ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span -- , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
) -- )
_ -> (acc + y, x) -- _ -> (acc + y, x)
(cmY, cmX) = foldl' folder (0, 0) finalComments -- (cmY, cmX) = foldl' folder (0, 0) finalComments
in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) -- in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
_ -> return () _ -> return ()
getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames :: LHsDecl GhcPs -> [String]
@ -539,10 +541,10 @@ getDeclBindingNames (L _ decl) = case decl of
-- This includes the imports -- This includes the imports
ppPreamble ppPreamble
:: GenLocated SrcSpan HsModule :: GenLocated SrcSpan HsModule
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -> PPM [{- (ExactPrint.KeywordId, ExactPrint.DeltaPos)-} ((), ())]
ppPreamble lmod@(L loc m@HsModule{}) = do ppPreamble lmod@(L loc m@HsModule{}) = do
filteredAnns <- mAsk <&> \annMap -> 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) -- Since ghc-exactprint adds annotations following (implicit)
-- modules to both HsModule and the elements in the module -- modules to both HsModule and the elements in the module
-- this can cause duplication of comments. So strip -- this can cause duplication of comments. So strip
@ -555,14 +557,14 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
let let
(filteredAnns', post) = (filteredAnns', post) =
case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of case Map.lookup ({-ExactPrint.mkAnnKey-} undefined lmod) filteredAnns of
Nothing -> (filteredAnns, []) Nothing -> (filteredAnns, [])
Just mAnn -> Just mAnn ->
let let
modAnnsDp = ExactPrint.annsDP mAnn modAnnsDp = undefined -- ExactPrint.annsDP mAnn
isWhere (ExactPrint.G AnnWhere) = True -- isWhere (ExactPrint.G AnnWhere) = True
isWhere _ = False isWhere _ = False
isEof (ExactPrint.AnnEofPos) = True -- isEof (ExactPrint.AnnEofPos) = True
isEof _ = False isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . 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 (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp) (Nothing, Just _i) -> ([], modAnnsDp)
(Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp
mAnn' = mAnn { ExactPrint.annsDP = pre } mAnn' = mAnn -- { ExactPrint.annsDP = pre }
filteredAnns'' = filteredAnns'' =
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns Map.insert ({-ExactPrint.mkAnnKey-} undefined lmod) mAnn' filteredAnns
in (filteredAnns'', post') in (filteredAnns'', post')
traceIfDumpConf traceIfDumpConf
"bridoc annotations filtered/transformed" "bridoc annotations filtered/transformed"
@ -582,7 +584,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
if shouldReformatPreamble if shouldReformatPreamble
then toLocal config filteredAnns' $ withTransformedAnns lmod $ do then toLocal config filteredAnns' $ withTransformedAnns lmod $ do
briDoc <- briDocMToPPM $ layoutModule lmod briDoc <- briDocMToPPM $ layoutModule (reLocA lmod)
layoutBriDoc briDoc layoutBriDoc briDoc
else else
let emptyModule = L loc m { hsmodDecls = [] } let emptyModule = L loc m { hsmodDecls = [] }
@ -667,16 +669,18 @@ layoutBriDoc briDoc = do
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let let
remainingComments :: [((), ())]
remainingComments = remainingComments =
[ c [
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList -- c
(_lstate_comments state') -- | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
-- With the new import layouter, we manually process comments -- (_lstate_comments state')
-- without relying on the backend to consume the comments out of -- -- With the new import layouter, we manually process comments
-- the state/map. So they will end up here, and we need to ignore -- -- without relying on the backend to consume the comments out of
-- them. -- -- the state/map. So they will end up here, and we need to ignore
, ExactPrint.unConName con /= "ImportDecl" -- -- them.
, c <- extractAllComments elemAnns -- , ExactPrint.unConName con /= "ImportDecl"
-- , c <- extractAllComments elemAnns
] ]
remainingComments remainingComments
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)

2
source/library/Language/Haskell/Brittany/Internal/EPCompat.hs
View File

@ -10,4 +10,4 @@ type Annotation = ()
type Anns = Map AnnKey () type Anns = Map AnnKey ()
type AnnKey = () type AnnKey = ()
type EPAnns = () type EPAnns = Map AnnKey ()

25
source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -182,29 +182,29 @@ commentAnnFixTransformGlob ast = undefined
-- ExactPrint.modifyAnnsT moveComments -- ExactPrint.modifyAnnsT moveComments
{--
-- | split a set of annotations in a module into a map from top-level module -- | 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 -- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have. -- implementation would have.
extractToplevelAnns extractToplevelAnns
:: Located HsModule :: Located HsModule
-> ExactPrint.Anns -> Anns
-> Map ExactPrint.AnnKey ExactPrint.Anns -> Map AnnKey Anns
extractToplevelAnns lmod anns = output extractToplevelAnns lmod anns = output
where where
(L _ (HsModule _ _ _ _ ldecls _ _)) = lmod (L _ (HsModule _ _ _ _ _ ldecls _ _)) = lmod
declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey declMap1 :: Map AnnKey AnnKey
declMap1 = Map.unions $ ldecls <&> \ldecl -> declMap1 = Map.unions $ ldecls <&> \ldecl ->
Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) Map.fromSet (const ({-ExactPrint.mkAnnKey-} undefined ldecl)) (foldedAnnKeys ldecl)
declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey declMap2 :: Map AnnKey AnnKey
declMap2 = declMap2 =
Map.fromList 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 declMap = declMap1 `Map.union` declMap2
modKey = ExactPrint.mkAnnKey lmod modKey = {-ExactPrint.mkAnnKey-} undefined lmod
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns 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) 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 Nothing = Just (Map.singleton k a)
insert k a (Just m) = Just (Map.insert k a m) 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 foldedAnnKeys ast = SYB.everything
Set.union Set.union
(\x -> maybe (\x -> maybe
Set.empty Set.empty
Set.singleton 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) | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
] ]
@ -232,7 +232,6 @@ foldedAnnKeys ast = SYB.everything
ast ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
-}
withTransformedAnns withTransformedAnns
:: Data ast :: Data ast