Build with ghc-9.2.1 #366
|
@ -39,9 +39,9 @@ flag pedantic
|
|||
common library
|
||||
build-depends:
|
||||
, aeson ^>= 2.0.1
|
||||
, base ^>= 4.15.0
|
||||
, base ^>= 4.16.0
|
||||
, butcher ^>= 1.3.3
|
||||
, bytestring ^>= 0.10.12
|
||||
, bytestring ^>= 0.11
|
||||
, cmdargs ^>= 0.10.21
|
||||
, containers ^>= 0.6.4
|
||||
, czipwith ^>= 1.0.1
|
||||
|
@ -50,10 +50,10 @@ common library
|
|||
, directory ^>= 1.3.6
|
||||
, extra ^>= 1.7.10
|
||||
, filepath ^>= 1.4.2
|
||||
, ghc ^>= 9.0.1
|
||||
, ghc-boot ^>= 9.0.1
|
||||
, ghc-boot-th ^>= 9.0.1
|
||||
, ghc-exactprint ^>= 0.6.4
|
||||
, ghc ^>= 9.2.1
|
||||
, ghc-boot ^>= 9.2.1
|
||||
, ghc-boot-th ^>= 9.2.1
|
||||
, ghc-exactprint ^>= 1.4
|
||||
, monad-memo ^>= 0.5.3
|
||||
, mtl ^>= 2.2.2
|
||||
, multistate ^>= 0.8.0
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -66,7 +66,7 @@ data ColBuildState = ColBuildState
|
|||
|
||||
type LayoutConstraints m
|
||||
= ( MonadMultiReader Config m
|
||||
, MonadMultiReader ExactPrint.Types.Anns m
|
||||
-- , MonadMultiReader ExactPrint.Types.Anns m
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
, MonadMultiState LayoutState m
|
||||
|
@ -138,12 +138,12 @@ layoutBriDocM = \case
|
|||
let
|
||||
tlines = Text.lines $ t <> Text.pack "\n"
|
||||
tlineCount = length tlines
|
||||
anns :: ExactPrint.Anns <- mAsk
|
||||
-- anns <- mAsk
|
||||
when shouldAddComment $ do
|
||||
layoutWriteAppend
|
||||
$ Text.pack
|
||||
$ "{-"
|
||||
++ show (annKey, Map.lookup annKey anns)
|
||||
++ show (annKey, Map.lookup annKey {-anns-} undefined :: Maybe String)
|
||||
++ "-}"
|
||||
zip [1 ..] tlines `forM_` \(i, l) -> do
|
||||
layoutWriteAppend $ l
|
||||
|
@ -152,7 +152,7 @@ layoutBriDocM = \case
|
|||
state <- mGet
|
||||
let filterF k _ = not $ k `Set.member` subKeys
|
||||
mSet $ state
|
||||
{ _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state
|
||||
{ _lstate_comments = undefined -- Map.filterWithKey filterF $ _lstate_comments state
|
||||
}
|
||||
BDPlain t -> do
|
||||
layoutWriteAppend t
|
||||
|
@ -162,12 +162,12 @@ layoutBriDocM = \case
|
|||
let
|
||||
moveToExactLocationAction = case _lstate_curYOrAddNewline state of
|
||||
Left{} -> pure ()
|
||||
Right{} -> moveToExactAnn annKey
|
||||
Right{} -> undefined -- moveToExactAnn annKey
|
||||
mAnn <- do
|
||||
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
|
||||
let mAnn = {-ExactPrint.annPriorComments-} undefined <$> Map.lookup annKey m
|
||||
mSet $ state
|
||||
{ _lstate_comments = Map.adjust
|
||||
(\ann -> ann { ExactPrint.annPriorComments = [] })
|
||||
(\ann -> ann {- ExactPrint.annPriorComments = [] -})
|
||||
annKey
|
||||
m
|
||||
}
|
||||
|
@ -177,20 +177,20 @@ layoutBriDocM = \case
|
|||
Just [] -> moveToExactLocationAction
|
||||
Just priors -> do
|
||||
-- layoutResetSepSpace
|
||||
priors
|
||||
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
|
||||
when (comment /= "(" && comment /= ")") $ do
|
||||
let commentLines = Text.lines $ Text.pack $ comment
|
||||
case comment of
|
||||
('#' : _) ->
|
||||
layoutMoveToCommentPos y (-999) (length commentLines)
|
||||
-- ^ evil hack for CPP
|
||||
_ -> layoutMoveToCommentPos y x (length commentLines)
|
||||
-- fixedX <- fixMoveToLineByIsNewline x
|
||||
-- replicateM_ fixedX layoutWriteNewline
|
||||
-- layoutMoveToIndentCol y
|
||||
layoutWriteAppendMultiline commentLines
|
||||
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
||||
-- priors
|
||||
-- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
|
||||
-- when (comment /= "(" && comment /= ")") $ do
|
||||
-- let commentLines = Text.lines $ Text.pack $ comment
|
||||
-- case comment of
|
||||
-- ('#' : _) ->
|
||||
-- layoutMoveToCommentPos y (-999) (length commentLines)
|
||||
-- -- ^ evil hack for CPP
|
||||
-- _ -> layoutMoveToCommentPos y x (length commentLines)
|
||||
-- -- fixedX <- fixMoveToLineByIsNewline x
|
||||
-- -- replicateM_ fixedX layoutWriteNewline
|
||||
-- -- layoutMoveToIndentCol y
|
||||
-- layoutWriteAppendMultiline commentLines
|
||||
-- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
||||
moveToExactLocationAction
|
||||
layoutBriDocM bd
|
||||
BDAnnotationKW annKey keyword bd -> do
|
||||
|
@ -198,22 +198,22 @@ layoutBriDocM = \case
|
|||
mComments <- do
|
||||
state <- mGet
|
||||
let m = _lstate_comments state
|
||||
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
|
||||
let mAnn = {-ExactPrint.annsDP-} undefined <$> Map.lookup annKey m
|
||||
let
|
||||
mToSpan = case mAnn of
|
||||
Just anns | Maybe.isNothing keyword -> Just anns
|
||||
Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
|
||||
Just annR
|
||||
-- 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)
|
||||
-- (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
|
||||
_ -> Nothing
|
||||
mSet $ state
|
||||
{ _lstate_comments = Map.adjust
|
||||
(\ann -> ann { ExactPrint.annsDP = rest })
|
||||
(\ann -> ann {- ExactPrint.annsDP = rest -})
|
||||
annKey
|
||||
m
|
||||
}
|
||||
|
@ -221,21 +221,22 @@ layoutBriDocM = \case
|
|||
_ -> return Nothing
|
||||
case mComments of
|
||||
Nothing -> pure ()
|
||||
Just comments -> do
|
||||
comments
|
||||
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
|
||||
when (comment /= "(" && comment /= ")") $ do
|
||||
let commentLines = Text.lines $ Text.pack $ comment
|
||||
-- evil hack for CPP:
|
||||
case comment of
|
||||
('#' : _) ->
|
||||
layoutMoveToCommentPos y (-999) (length commentLines)
|
||||
_ -> layoutMoveToCommentPos y x (length commentLines)
|
||||
-- fixedX <- fixMoveToLineByIsNewline x
|
||||
-- replicateM_ fixedX layoutWriteNewline
|
||||
-- layoutMoveToIndentCol y
|
||||
layoutWriteAppendMultiline commentLines
|
||||
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
||||
Just comments -> undefined
|
||||
-- do
|
||||
-- comments
|
||||
-- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
|
||||
-- when (comment /= "(" && comment /= ")") $ do
|
||||
-- let commentLines = Text.lines $ Text.pack $ comment
|
||||
-- -- evil hack for CPP:
|
||||
-- case comment of
|
||||
-- ('#' : _) ->
|
||||
-- layoutMoveToCommentPos y (-999) (length commentLines)
|
||||
-- _ -> layoutMoveToCommentPos y x (length commentLines)
|
||||
-- -- fixedX <- fixMoveToLineByIsNewline x
|
||||
-- -- replicateM_ fixedX layoutWriteNewline
|
||||
-- -- layoutMoveToIndentCol y
|
||||
-- layoutWriteAppendMultiline commentLines
|
||||
-- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
||||
BDAnnotationRest annKey bd -> do
|
||||
layoutBriDocM bd
|
||||
annMay <- do
|
||||
|
@ -247,7 +248,7 @@ layoutBriDocM = \case
|
|||
semiCount = length
|
||||
[ ()
|
||||
| Just ann <- [annMay]
|
||||
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
|
||||
-- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
|
||||
]
|
||||
shouldAddSemicolonNewlines <-
|
||||
mAsk
|
||||
|
@ -257,12 +258,12 @@ layoutBriDocM = \case
|
|||
mModify $ \state -> state
|
||||
{ _lstate_comments = Map.adjust
|
||||
(\ann -> ann
|
||||
{ ExactPrint.annFollowingComments = []
|
||||
, ExactPrint.annPriorComments = []
|
||||
, ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
|
||||
(ExactPrint.Types.AnnComment{}, _) -> False
|
||||
_ -> True
|
||||
}
|
||||
-- { ExactPrint.annFollowingComments = []
|
||||
-- , ExactPrint.annPriorComments = []
|
||||
-- , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
|
||||
-- (ExactPrint.Types.AnnComment{}, _) -> False
|
||||
-- _ -> True
|
||||
-- }
|
||||
)
|
||||
annKey
|
||||
(_lstate_comments state)
|
||||
|
@ -271,41 +272,44 @@ layoutBriDocM = \case
|
|||
Nothing -> do
|
||||
when shouldAddSemicolonNewlines $ do
|
||||
[1 .. semiCount] `forM_` const layoutWriteNewline
|
||||
Just comments -> do
|
||||
comments
|
||||
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
|
||||
when (comment /= "(" && comment /= ")") $ do
|
||||
let commentLines = Text.lines $ Text.pack comment
|
||||
case comment of
|
||||
('#' : _) -> layoutMoveToCommentPos y (-999) 1
|
||||
-- ^ evil hack for CPP
|
||||
")" -> pure ()
|
||||
-- ^ fixes the formatting of parens
|
||||
-- on the lhs of type alias defs
|
||||
_ -> layoutMoveToCommentPos y x (length commentLines)
|
||||
-- fixedX <- fixMoveToLineByIsNewline x
|
||||
-- replicateM_ fixedX layoutWriteNewline
|
||||
-- layoutMoveToIndentCol y
|
||||
layoutWriteAppendMultiline commentLines
|
||||
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
||||
Just comments -> undefined
|
||||
-- do
|
||||
-- comments
|
||||
-- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
|
||||
-- when (comment /= "(" && comment /= ")") $ do
|
||||
-- let commentLines = Text.lines $ Text.pack comment
|
||||
-- case comment of
|
||||
-- ('#' : _) -> layoutMoveToCommentPos y (-999) 1
|
||||
-- -- ^ evil hack for CPP
|
||||
-- ")" -> pure ()
|
||||
-- -- ^ fixes the formatting of parens
|
||||
-- -- on the lhs of type alias defs
|
||||
-- _ -> layoutMoveToCommentPos y x (length commentLines)
|
||||
-- -- fixedX <- fixMoveToLineByIsNewline x
|
||||
-- -- replicateM_ fixedX layoutWriteNewline
|
||||
-- -- layoutMoveToIndentCol y
|
||||
-- layoutWriteAppendMultiline commentLines
|
||||
-- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
|
||||
BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
|
||||
mDP <- do
|
||||
state <- mGet
|
||||
let m = _lstate_comments state
|
||||
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
|
||||
-- let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
|
||||
let
|
||||
relevant =
|
||||
[ dp
|
||||
| Just ann <- [mAnn]
|
||||
, (ExactPrint.Types.G kw1, dp) <- ann
|
||||
, keyword == kw1
|
||||
]
|
||||
relevant = undefined
|
||||
-- [ dp
|
||||
-- | Just ann <- [mAnn]
|
||||
-- -- , (ExactPrint.Types.G kw1, dp) <- ann
|
||||
|
||||
-- , keyword == kw1
|
||||
-- ]
|
||||
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
|
||||
case relevant of
|
||||
[] -> pure Nothing
|
||||
(ExactPrint.Types.DP (y, x) : _) -> do
|
||||
mSet state { _lstate_commentNewlines = 0 }
|
||||
pure $ Just (y - _lstate_commentNewlines state, x)
|
||||
_ -> pure undefined
|
||||
-- (ExactPrint.Types.DP (y, x) : _) -> do
|
||||
-- mSet state { _lstate_commentNewlines = 0 }
|
||||
-- pure $ Just (y - _lstate_commentNewlines state, x)
|
||||
case mDP of
|
||||
Nothing -> pure ()
|
||||
Just (y, x) ->
|
||||
|
|
|
@ -17,7 +17,7 @@ import Language.Haskell.Brittany.Internal.Prelude
|
|||
import Language.Haskell.Brittany.Internal.PreludeUtils
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
|
||||
-- import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||
|
||||
|
||||
|
@ -338,23 +338,23 @@ layoutAddSepSpace = do
|
|||
|
||||
-- TODO: when refactoring is complete, the other version of this method
|
||||
-- can probably be removed.
|
||||
moveToExactAnn
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiReader (Map AnnKey Annotation) m
|
||||
)
|
||||
=> AnnKey
|
||||
-> m ()
|
||||
moveToExactAnn annKey = do
|
||||
traceLocal ("moveToExactAnn", annKey)
|
||||
anns <- mAsk
|
||||
case Map.lookup annKey anns of
|
||||
Nothing -> return ()
|
||||
Just ann -> do
|
||||
-- curY <- mGet <&> _lstate_curY
|
||||
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
|
||||
-- mModify $ \state -> state { _lstate_addNewline = Just x }
|
||||
moveToY y
|
||||
-- moveToExactAnn
|
||||
-- :: ( MonadMultiWriter Text.Builder.Builder m
|
||||
-- , MonadMultiState LayoutState m
|
||||
-- -- , MonadMultiReader (Map AnnKey Annotation) m
|
||||
-- )
|
||||
-- => AnnKey
|
||||
-- -> m ()
|
||||
-- moveToExactAnn annKey = do
|
||||
-- traceLocal ("moveToExactAnn", annKey)
|
||||
-- anns <- mAsk
|
||||
-- case Map.lookup annKey anns of
|
||||
-- Nothing -> return ()
|
||||
-- Just ann -> do
|
||||
-- -- curY <- mGet <&> _lstate_curY
|
||||
-- let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
|
||||
-- -- mModify $ \state -> state { _lstate_addNewline = Just x }
|
||||
-- moveToY y
|
||||
|
||||
moveToY :: MonadMultiState LayoutState m => Int -> m ()
|
||||
moveToY y = mModify $ \state ->
|
||||
|
@ -379,77 +379,77 @@ moveToY y = mModify $ \state ->
|
|||
-- then x-1
|
||||
-- else x
|
||||
|
||||
ppmMoveToExactLoc
|
||||
:: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
|
||||
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
|
||||
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
|
||||
replicateM_ y $ mTell $ Text.Builder.fromString " "
|
||||
-- ppmMoveToExactLoc
|
||||
-- :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
|
||||
-- ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
|
||||
-- replicateM_ x $ mTell $ Text.Builder.fromString "\n"
|
||||
-- replicateM_ y $ mTell $ Text.Builder.fromString " "
|
||||
|
||||
-- TODO: update and use, or clean up. Currently dead code.
|
||||
layoutWritePriorComments
|
||||
:: ( Data.Data.Data ast
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
)
|
||||
=> Located ast
|
||||
-> m ()
|
||||
layoutWritePriorComments ast = do
|
||||
mAnn <- do
|
||||
state <- mGet
|
||||
let key = ExactPrint.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
|
||||
case mAnn of
|
||||
Nothing -> return ()
|
||||
Just priors -> do
|
||||
unless (null priors) $ layoutSetCommentCol
|
||||
priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
|
||||
do
|
||||
replicateM_ x layoutWriteNewline
|
||||
layoutWriteAppendSpaces y
|
||||
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
|
||||
-- layoutWritePriorComments
|
||||
-- :: ( Data.Data.Data ast
|
||||
-- , MonadMultiWriter Text.Builder.Builder m
|
||||
-- , MonadMultiState LayoutState m
|
||||
-- )
|
||||
-- => Located ast
|
||||
-- -> m ()
|
||||
-- layoutWritePriorComments ast = do
|
||||
-- mAnn <- do
|
||||
-- state <- mGet
|
||||
-- let key = ExactPrint.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
|
||||
-- case mAnn of
|
||||
-- Nothing -> return ()
|
||||
-- Just priors -> do
|
||||
-- unless (null priors) $ layoutSetCommentCol
|
||||
-- priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
|
||||
-- do
|
||||
-- replicateM_ x layoutWriteNewline
|
||||
-- layoutWriteAppendSpaces y
|
||||
-- layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
|
||||
|
||||
-- TODO: update and use, or clean up. Currently dead code.
|
||||
-- this currently only extracs from the `annsDP` field of Annotations.
|
||||
-- per documentation, this seems sufficient, as the
|
||||
-- "..`annFollowingComments` are only added by AST transformations ..".
|
||||
layoutWritePostComments
|
||||
:: ( Data.Data.Data ast
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
)
|
||||
=> Located ast
|
||||
-> m ()
|
||||
layoutWritePostComments ast = do
|
||||
mAnn <- do
|
||||
state <- mGet
|
||||
let key = ExactPrint.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
|
||||
case mAnn of
|
||||
Nothing -> return ()
|
||||
Just posts -> do
|
||||
unless (null posts) $ layoutSetCommentCol
|
||||
posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
|
||||
do
|
||||
replicateM_ x layoutWriteNewline
|
||||
layoutWriteAppend $ Text.pack $ replicate y ' '
|
||||
mModify $ \s -> s { _lstate_addSepSpace = Nothing }
|
||||
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
|
||||
-- layoutWritePostComments
|
||||
-- :: ( Data.Data.Data ast
|
||||
-- , MonadMultiWriter Text.Builder.Builder m
|
||||
-- , MonadMultiState LayoutState m
|
||||
-- )
|
||||
-- => Located ast
|
||||
-- -> m ()
|
||||
-- layoutWritePostComments ast = do
|
||||
-- mAnn <- do
|
||||
-- state <- mGet
|
||||
-- let key = ExactPrint.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
|
||||
-- case mAnn of
|
||||
-- Nothing -> return ()
|
||||
-- Just posts -> do
|
||||
-- unless (null posts) $ layoutSetCommentCol
|
||||
-- posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
|
||||
-- do
|
||||
-- replicateM_ x layoutWriteNewline
|
||||
-- layoutWriteAppend $ Text.pack $ replicate y ' '
|
||||
-- mModify $ \s -> s { _lstate_addSepSpace = Nothing }
|
||||
-- layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
|
||||
|
||||
layoutIndentRestorePostComment
|
||||
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
|
||||
|
|
|
@ -0,0 +1,13 @@
|
|||
module Language.Haskell.Brittany.Internal.EPCompat where
|
||||
|
||||
import Data.Map (Map)
|
||||
|
||||
type DeltaPos = ()
|
||||
type Comment = ()
|
||||
|
||||
type Annotation = ()
|
||||
|
||||
type Anns = Map AnnKey ()
|
||||
type AnnKey = ()
|
||||
|
||||
type EPAnns = Map AnnKey ()
|
|
@ -31,13 +31,13 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
|||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||
import qualified System.IO
|
||||
|
||||
|
||||
import Language.Haskell.Brittany.Internal.EPCompat
|
||||
|
||||
parseModule
|
||||
:: [String]
|
||||
-> System.IO.FilePath
|
||||
-> (GHC.DynFlags -> IO (Either String a))
|
||||
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
|
||||
-> IO (Either String (GHC.ParsedSource, a))
|
||||
parseModule args fp dynCheck = do
|
||||
str <- System.IO.readFile fp
|
||||
parseModuleFromString args fp dynCheck str
|
||||
|
@ -47,74 +47,75 @@ parseModuleFromString
|
|||
-> System.IO.FilePath
|
||||
-> (GHC.DynFlags -> IO (Either String a))
|
||||
-> String
|
||||
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
|
||||
-> IO (Either String (GHC.ParsedSource, a))
|
||||
parseModuleFromString = ParseModule.parseModule
|
||||
|
||||
|
||||
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.ext1Q` (\l@(L span _) ->
|
||||
Seq.singleton (span, ExactPrint.mkAnnKey l)
|
||||
)
|
||||
let nodes = SYB.everything (<>) extract ast
|
||||
let
|
||||
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
|
||||
annsMap = Map.fromListWith
|
||||
(const id)
|
||||
[ (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.realSrcSpanStart $ ExactPrint.commentIdentifier com of
|
||||
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.realSrcSpanStart annKeyLoc1
|
||||
loc2 = GHC.realSrcSpanStart 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' <- filterM processCom priors
|
||||
follows' <- filterM processCom follows
|
||||
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
|
||||
commentAnnFixTransformGlob ast = undefined
|
||||
-- do
|
||||
-- let
|
||||
-- extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
|
||||
-- extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
|
||||
-- const Seq.empty
|
||||
-- `SYB.ext1Q` (\l@(L span _) ->
|
||||
-- Seq.singleton (span, ExactPrint.mkAnnKey l)
|
||||
-- )
|
||||
-- let nodes = SYB.everything (<>) extract ast
|
||||
-- let
|
||||
-- annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
|
||||
-- annsMap = Map.fromListWith
|
||||
-- (const id)
|
||||
-- [ (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.realSrcSpanStart $ ExactPrint.commentIdentifier com of
|
||||
-- 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.realSrcSpanStart annKeyLoc1
|
||||
-- loc2 = GHC.realSrcSpanStart 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' <- filterM processCom priors
|
||||
-- follows' <- filterM processCom follows
|
||||
-- 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
|
||||
|
||||
|
||||
-- TODO: this is unused by now, but it contains one detail that
|
||||
|
@ -181,27 +182,29 @@ commentAnnFixTransformGlob ast = do
|
|||
|
||||
-- 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)
|
||||
|
@ -212,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
|
||||
]
|
||||
|
@ -233,8 +236,8 @@ foldedAnnKeys ast = SYB.everything
|
|||
withTransformedAnns
|
||||
:: Data ast
|
||||
=> ast
|
||||
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
|
||||
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
|
||||
-> MultiRWSS.MultiRWS '[Config , Anns] w s a
|
||||
-> MultiRWSS.MultiRWS '[Config , Anns] w s a
|
||||
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
|
||||
readers@(conf :+: anns :+: HNil) -> do
|
||||
-- TODO: implement `local` for MultiReader/MultiRWS
|
||||
|
@ -245,9 +248,9 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
|
|||
where
|
||||
f anns =
|
||||
let
|
||||
((), (annsBalanced, _), _) =
|
||||
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
|
||||
in annsBalanced
|
||||
((), _, _) =
|
||||
ExactPrint.runTransform (commentAnnFixTransformGlob ast)
|
||||
in anns
|
||||
|
||||
|
||||
warnExtractorCompat :: GHC.Warn -> String
|
||||
|
|
|
@ -17,7 +17,7 @@ import qualified Data.Set as Set
|
|||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import DataTreePrint
|
||||
import GHC (GenLocated(L), Located, moduleName, moduleNameString)
|
||||
import GHC (GenLocated(L), Located, LocatedAn, moduleName, moduleNameString)
|
||||
import qualified GHC.OldList as List
|
||||
import GHC.Parser.Annotation (AnnKeywordId(..))
|
||||
import GHC.Types.Name (getOccString)
|
||||
|
@ -31,24 +31,26 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
|
|||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
|
||||
-- import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
|
||||
-- import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
|
||||
|
||||
|
||||
import Language.Haskell.Brittany.Internal.EPCompat
|
||||
|
||||
processDefault
|
||||
:: ( ExactPrint.Annotate.Annotate ast
|
||||
:: (
|
||||
-- ExactPrint.Annotate.Annotate ast
|
||||
ExactPrint.ExactPrint ast
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiReader ExactPrint.Types.Anns m
|
||||
-- , MonadMultiReader ExactPrint.Types.Anns m
|
||||
)
|
||||
=> Located ast
|
||||
-> m ()
|
||||
processDefault x = do
|
||||
anns <- mAsk
|
||||
let str = ExactPrint.exactPrint x anns
|
||||
-- anns <- mAsk
|
||||
let str = ExactPrint.exactPrint x {-anns-}
|
||||
-- this hack is here so our print-empty-module trick does not add
|
||||
-- a newline at the start if there actually is no module header / imports
|
||||
-- / anything.
|
||||
|
@ -63,16 +65,18 @@ processDefault x = do
|
|||
-- not handled by brittany yet). Useful when starting implementing new
|
||||
-- syntactic constructs when children are not handled yet.
|
||||
briDocByExact
|
||||
:: (ExactPrint.Annotate.Annotate ast)
|
||||
=> Located ast
|
||||
::
|
||||
-- (ExactPrint.Annotate.Annotate ast)
|
||||
(Data ast, Data an)
|
||||
=> LocatedAn an ast
|
||||
-> ToBriDocM BriDocNumbered
|
||||
briDocByExact ast = do
|
||||
anns <- mAsk
|
||||
-- anns <- mAsk
|
||||
traceIfDumpConf
|
||||
"ast"
|
||||
_dconf_dump_ast_unknown
|
||||
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
||||
docExt ast anns True
|
||||
(printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
|
||||
docExt ast {-anns-} True
|
||||
|
||||
-- | Use ExactPrint's output for this node.
|
||||
-- Consider that for multi-line input, the indentation of the code produced
|
||||
|
@ -80,38 +84,44 @@ briDocByExact ast = do
|
|||
-- of its surroundings as layouted by brittany. But there are safe uses of
|
||||
-- this, e.g. for any top-level declarations.
|
||||
briDocByExactNoComment
|
||||
:: (ExactPrint.Annotate.Annotate ast)
|
||||
=> Located ast
|
||||
::
|
||||
-- (ExactPrint.Annotate.Annotate ast)
|
||||
(Data ast, Data an)
|
||||
=> LocatedAn an ast
|
||||
-> ToBriDocM BriDocNumbered
|
||||
briDocByExactNoComment ast = do
|
||||
anns <- mAsk
|
||||
-- anns <- mAsk
|
||||
traceIfDumpConf
|
||||
"ast"
|
||||
_dconf_dump_ast_unknown
|
||||
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
||||
docExt ast anns False
|
||||
(printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
|
||||
docExt ast {-anns-} False
|
||||
|
||||
-- | Use ExactPrint's output for this node, presuming that this output does
|
||||
-- not contain any newlines. If this property is not met, the semantics
|
||||
-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
|
||||
briDocByExactInlineOnly
|
||||
:: (ExactPrint.Annotate.Annotate ast)
|
||||
::
|
||||
-- (ExactPrint.Annotate.Annotate ast)
|
||||
(Data ast, ExactPrint.ExactPrint (LocatedAn an ast), Data an)
|
||||
=> String
|
||||
-> Located ast
|
||||
-> LocatedAn an ast
|
||||
-> ToBriDocM BriDocNumbered
|
||||
briDocByExactInlineOnly infoStr ast = do
|
||||
anns <- mAsk
|
||||
-- anns <- mAsk
|
||||
traceIfDumpConf
|
||||
"ast"
|
||||
_dconf_dump_ast_unknown
|
||||
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
||||
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
|
||||
(printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
|
||||
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast {-anns-}
|
||||
fallbackMode <-
|
||||
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
|
||||
let
|
||||
exactPrintNode t = allocateNode $ BDFExternal
|
||||
(ExactPrint.Types.mkAnnKey ast)
|
||||
(foldedAnnKeys ast)
|
||||
-- ({-ExactPrint.Types.mkAnnKey-} undefined ast)
|
||||
undefined
|
||||
-- (foldedAnnKeys ast)
|
||||
undefined
|
||||
False
|
||||
t
|
||||
let
|
||||
|
@ -138,38 +148,48 @@ lrdrNameToText :: GenLocated l RdrName -> Text
|
|||
lrdrNameToText (L _ n) = rdrNameToText n
|
||||
|
||||
lrdrNameToTextAnnGen
|
||||
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
:: (MonadMultiReader Config m
|
||||
-- , MonadMultiReader (Map AnnKey Annotation) m
|
||||
)
|
||||
=> (Text -> Text)
|
||||
-> Located RdrName
|
||||
-> LocatedAn an RdrName
|
||||
-> m Text
|
||||
lrdrNameToTextAnnGen f ast@(L _ n) = do
|
||||
anns <- mAsk
|
||||
-- anns <- mAsk
|
||||
let t = f $ rdrNameToText n
|
||||
let
|
||||
hasUni x (ExactPrint.Types.G y, _) = x == y
|
||||
-- hasUni x (ExactPrint.Types.G y, _) = x == y
|
||||
hasUni _ _ = False
|
||||
-- TODO: in general: we should _always_ process all annotaiton stuff here.
|
||||
-- whatever we don't probably should have had some effect on the
|
||||
-- output. in such cases, resorting to byExact is probably the safe
|
||||
-- choice.
|
||||
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
|
||||
return $ case {-Map.lookup ({-ExactPrint.Types.mkAnnKey-} undefined ast) anns-} undefined of
|
||||
Nothing -> t
|
||||
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
|
||||
Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} _ -> case n of
|
||||
Exact{} | t == Text.pack "()" -> t
|
||||
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
|
||||
_ | any (hasUni AnnCommaTuple) aks -> t
|
||||
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
|
||||
_ | otherwise -> t
|
||||
|
||||
where
|
||||
aks :: [a]
|
||||
aks = undefined
|
||||
|
||||
lrdrNameToTextAnn
|
||||
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
=> Located RdrName
|
||||
:: (MonadMultiReader Config m
|
||||
-- , MonadMultiReader (Map AnnKey Annotation) m
|
||||
)
|
||||
=> LocatedAn an RdrName
|
||||
-> m Text
|
||||
lrdrNameToTextAnn = lrdrNameToTextAnnGen id
|
||||
|
||||
lrdrNameToTextAnnTypeEqualityIsSpecial
|
||||
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
=> Located RdrName
|
||||
:: (MonadMultiReader Config m
|
||||
-- , MonadMultiReader (Map AnnKey Annotation) m
|
||||
)
|
||||
=> LocatedAn an RdrName
|
||||
-> m Text
|
||||
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
|
||||
let
|
||||
|
@ -186,10 +206,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
|
|||
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
|
||||
:: ( Data ast
|
||||
, MonadMultiReader Config m
|
||||
, MonadMultiReader (Map AnnKey Annotation) m
|
||||
-- , MonadMultiReader (Map AnnKey Annotation) m
|
||||
)
|
||||
=> Located ast
|
||||
-> Located RdrName
|
||||
=> LocatedAn an ast
|
||||
-> LocatedAn an RdrName
|
||||
-> m Text
|
||||
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
|
||||
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
|
||||
|
@ -205,60 +225,62 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
|
|||
|
||||
|
||||
extractAllComments
|
||||
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
|
||||
:: Annotation -> [(Comment, DeltaPos)]
|
||||
extractAllComments ann =
|
||||
ExactPrint.annPriorComments ann ++ extractRestComments ann
|
||||
undefined
|
||||
-- ExactPrint.annPriorComments ann ++ extractRestComments ann
|
||||
|
||||
extractRestComments
|
||||
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
|
||||
:: Annotation -> [(Comment, DeltaPos)]
|
||||
extractRestComments ann =
|
||||
ExactPrint.annFollowingComments ann
|
||||
++ (ExactPrint.annsDP ann >>= \case
|
||||
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
|
||||
_ -> []
|
||||
)
|
||||
undefined
|
||||
-- ExactPrint.annFollowingComments ann
|
||||
-- ++ (ExactPrint.annsDP ann >>= \case
|
||||
-- (ExactPrint.AnnComment com, dp) -> [(com, dp)]
|
||||
-- _ -> []
|
||||
-- )
|
||||
|
||||
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
|
||||
filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
|
||||
-- filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
|
||||
-- filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
|
||||
|
||||
-- | True if there are any comments that are
|
||||
-- a) connected to any node below (in AST sense) the given node AND
|
||||
-- b) after (in source code order) the node.
|
||||
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
||||
hasAnyCommentsBelow :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
|
||||
hasAnyCommentsBelow ast@(L l _) =
|
||||
List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
|
||||
List.any (\(c, _) -> {-ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l-} undefined)
|
||||
<$> astConnectedComments ast
|
||||
|
||||
hasCommentsBetween
|
||||
:: Data ast
|
||||
=> GHC.Located ast
|
||||
=> GHC.LocatedAn an ast
|
||||
-> AnnKeywordId
|
||||
-> AnnKeywordId
|
||||
-> ToBriDocM Bool
|
||||
hasCommentsBetween ast leftKey rightKey = do
|
||||
mAnn <- astAnn ast
|
||||
mAnn <- {-astAnn-} undefined ast
|
||||
let
|
||||
go1 [] = False
|
||||
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
|
||||
-- go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
|
||||
go1 (_ : rest) = go1 rest
|
||||
go2 [] = False
|
||||
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
|
||||
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
|
||||
-- go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
|
||||
-- go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
|
||||
go2 (_ : rest) = go2 rest
|
||||
case mAnn of
|
||||
Nothing -> pure False
|
||||
Just ann -> pure $ go1 $ ExactPrint.annsDP ann
|
||||
Just ann -> pure $ go1 $ undefined ann
|
||||
|
||||
-- | True if there are any comments that are connected to any node below (in AST
|
||||
-- sense) the given node
|
||||
hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
||||
hasAnyCommentsConnected :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
|
||||
hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
|
||||
|
||||
-- | True if there are any regular comments connected to any node below (in AST
|
||||
-- sense) the given node
|
||||
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
||||
hasAnyRegularCommentsConnected :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
|
||||
hasAnyRegularCommentsConnected ast =
|
||||
any isRegularComment <$> astConnectedComments ast
|
||||
any {-isRegularComment-} undefined <$> astConnectedComments ast
|
||||
|
||||
-- | Regular comments are comments that are actually "source code comments",
|
||||
-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
|
||||
|
@ -269,51 +291,61 @@ hasAnyRegularCommentsConnected ast =
|
|||
-- I believe that most of the time we branch on the existence of comments, we
|
||||
-- only care about "regular" comments. We simply did not need the distinction
|
||||
-- because "irregular" comments are not that common outside of type/data decls.
|
||||
isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
|
||||
isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
|
||||
-- isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
|
||||
-- isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
|
||||
|
||||
astConnectedComments
|
||||
:: Data ast
|
||||
=> GHC.Located ast
|
||||
-> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]
|
||||
=> GHC.LocatedAn an ast
|
||||
-> ToBriDocM [(Comment, DeltaPos)]
|
||||
astConnectedComments ast = do
|
||||
anns <- filterAnns ast <$> mAsk
|
||||
pure $ extractAllComments =<< Map.elems anns
|
||||
undefined
|
||||
-- anns <- filterAnns ast <$> mAsk
|
||||
-- pure $ extractAllComments =<< Map.elems anns
|
||||
|
||||
hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
||||
hasAnyCommentsPrior ast = astAnn ast <&> \case
|
||||
hasAnyCommentsPrior ast = {-astAnn-} undefined ast <&> \case
|
||||
Nothing -> False
|
||||
Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
|
||||
Just _ {-(ExactPrint.Types.Ann _ priors _ _ _ _)-} -> not $ null priors
|
||||
where priors = [undefined]
|
||||
|
||||
hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
||||
hasAnyRegularCommentsRest ast = astAnn ast <&> \case
|
||||
hasAnyRegularCommentsRest :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
|
||||
hasAnyRegularCommentsRest ast = {-astAnn-} undefined ast <&> \case
|
||||
Nothing -> False
|
||||
Just ann -> any isRegularComment (extractRestComments ann)
|
||||
Just ann -> undefined -- any isRegularComment (extractRestComments ann)
|
||||
|
||||
hasAnnKeywordComment
|
||||
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
|
||||
hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
|
||||
:: Data ast => GHC.LocatedAn an ast -> AnnKeywordId -> ToBriDocM Bool
|
||||
hasAnnKeywordComment ast annKeyword = {-astAnn-} undefined ast <&> \case
|
||||
Nothing -> False
|
||||
Just ann -> any hasK (extractAllComments ann)
|
||||
where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
|
||||
Just ann -> any hasK ({-extractAllComments-} thing ann)
|
||||
where
|
||||
hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
|
||||
thing ann = [undefined]
|
||||
|
||||
hasAnnKeyword
|
||||
:: (Data a, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
=> Located a
|
||||
:: (Data a
|
||||
-- , MonadMultiReader (Map AnnKey Annotation) m
|
||||
, Functor m
|
||||
)
|
||||
=> LocatedAn an a
|
||||
-> AnnKeywordId
|
||||
-> m Bool
|
||||
hasAnnKeyword ast annKeyword = astAnn ast <&> \case
|
||||
hasAnnKeyword ast annKeyword = {-astAnn-} astAnn' ast <&> \case
|
||||
Nothing -> False
|
||||
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
|
||||
Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} undefined -> any hasK aks
|
||||
where
|
||||
hasK (ExactPrint.Types.G x, _) = x == annKeyword
|
||||
-- hasK (ExactPrint.Types.G x, _) = x == annKeyword
|
||||
hasK _ = False
|
||||
aks = [undefined]
|
||||
-- astAnn' :: Functor f => Located a -> f (Maybe b)
|
||||
astAnn' = undefined
|
||||
|
||||
astAnn
|
||||
:: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
=> GHC.Located ast
|
||||
-> m (Maybe Annotation)
|
||||
astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk
|
||||
-- astAnn
|
||||
-- :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
-- => GHC.Located ast
|
||||
-- -> m (Maybe Annotation)
|
||||
-- astAnn ast = {-Map.lookup ({-ExactPrint.Types.mkAnnKey-} undefined ast)-} undefined <$> mAsk
|
||||
|
||||
-- new BriDoc stuff
|
||||
|
||||
|
@ -338,7 +370,7 @@ allocNodeIndex = do
|
|||
-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)
|
||||
-- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered
|
||||
-- docExt x anns shouldAddComment = allocateNode $ BDFExternal
|
||||
-- (ExactPrint.Types.mkAnnKey x)
|
||||
-- ({-ExactPrint.Types.mkAnnKey-} undefined x)
|
||||
-- (foldedAnnKeys x)
|
||||
-- shouldAddComment
|
||||
-- (Text.pack $ ExactPrint.exactPrint x anns)
|
||||
|
@ -393,7 +425,7 @@ allocNodeIndex = do
|
|||
-- -> m BriDocNumbered
|
||||
-- docPostComment ast bdm = do
|
||||
-- bd <- bdm
|
||||
-- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd
|
||||
-- allocateNode $ BDFAnnotationPost ({-ExactPrint.Types.mkAnnKey-} undefined ast) bd
|
||||
--
|
||||
-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
|
||||
-- => Located ast
|
||||
|
@ -405,9 +437,9 @@ allocNodeIndex = do
|
|||
-- i2 <- allocNodeIndex
|
||||
-- return
|
||||
-- $ (,) i1
|
||||
-- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
|
||||
-- $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast)
|
||||
-- $ (,) i2
|
||||
-- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
|
||||
-- $ BDFAnnotationPost ({-ExactPrint.Types.mkAnnKey-} undefined ast)
|
||||
-- $ bd
|
||||
--
|
||||
-- docPar :: MonadMultiState NodeAllocIndex m
|
||||
|
@ -438,16 +470,19 @@ docLitS :: String -> ToBriDocM BriDocNumbered
|
|||
docLitS s = allocateNode $ BDFLit $ Text.pack s
|
||||
|
||||
docExt
|
||||
:: (ExactPrint.Annotate.Annotate ast)
|
||||
=> Located ast
|
||||
-> ExactPrint.Types.Anns
|
||||
::
|
||||
-- (ExactPrint.Annotate.Annotate ast)
|
||||
LocatedAn an ast
|
||||
-- -> ExactPrint.Types.Anns
|
||||
-> Bool
|
||||
-> ToBriDocM BriDocNumbered
|
||||
docExt x anns shouldAddComment = allocateNode $ BDFExternal
|
||||
(ExactPrint.Types.mkAnnKey x)
|
||||
(foldedAnnKeys x)
|
||||
docExt x shouldAddComment = allocateNode $ BDFExternal
|
||||
-- ({-ExactPrint.Types.mkAnnKey-} undefined x)
|
||||
undefined
|
||||
-- (foldedAnnKeys x)
|
||||
undefined
|
||||
shouldAddComment
|
||||
(Text.pack $ ExactPrint.exactPrint x anns)
|
||||
(Text.pack $ {-ExactPrint.exactPrint x anns-} undefined)
|
||||
|
||||
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
||||
docAlt l = allocateNode . BDFAlt =<< sequence l
|
||||
|
@ -580,34 +615,34 @@ docTick = docLit $ Text.pack "'"
|
|||
|
||||
docNodeAnnKW
|
||||
:: Data.Data.Data ast
|
||||
=> Located ast
|
||||
=> LocatedAn an ast
|
||||
-> Maybe AnnKeywordId
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
docNodeAnnKW ast kw bdm =
|
||||
docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm
|
||||
docAnnotationKW ({-{-ExactPrint.Types.mkAnnKey-} undefined-} undefined ast) kw bdm
|
||||
|
||||
docNodeMoveToKWDP
|
||||
:: Data.Data.Data ast
|
||||
=> Located ast
|
||||
=> LocatedAn an ast
|
||||
-> AnnKeywordId
|
||||
-> Bool
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
|
||||
docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm
|
||||
docMoveToKWDP ({-{-ExactPrint.Types.mkAnnKey-} undefined-} undefined ast) kw shouldRestoreIndent bdm
|
||||
|
||||
class DocWrapable a where
|
||||
docWrapNode :: ( Data.Data.Data ast)
|
||||
=> Located ast
|
||||
=> LocatedAn an ast
|
||||
-> a
|
||||
-> a
|
||||
docWrapNodePrior :: ( Data.Data.Data ast)
|
||||
=> Located ast
|
||||
=> LocatedAn an ast
|
||||
-> a
|
||||
-> a
|
||||
docWrapNodeRest :: ( Data.Data.Data ast)
|
||||
=> Located ast
|
||||
=> LocatedAn an ast
|
||||
-> a
|
||||
-> a
|
||||
|
||||
|
@ -618,18 +653,18 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
|
|||
i2 <- allocNodeIndex
|
||||
return
|
||||
$ (,) i1
|
||||
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
|
||||
$ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast)
|
||||
$ (,) i2
|
||||
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
|
||||
$ BDFAnnotationRest ({-ExactPrint.Types.mkAnnKey-} undefined ast)
|
||||
$ bd
|
||||
docWrapNodePrior ast bdm = do
|
||||
bd <- bdm
|
||||
i1 <- allocNodeIndex
|
||||
return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
|
||||
return $ (,) i1 $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd
|
||||
docWrapNodeRest ast bdm = do
|
||||
bd <- bdm
|
||||
i2 <- allocNodeIndex
|
||||
return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
|
||||
return $ (,) i2 $ BDFAnnotationRest ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd
|
||||
|
||||
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
|
||||
docWrapNode ast bdms = case bdms of
|
||||
|
@ -746,7 +781,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
|
|||
unknownNodeError
|
||||
:: Data.Data.Data ast
|
||||
=> String
|
||||
-> GenLocated GHC.SrcSpan ast
|
||||
-> LocatedAn an ast
|
||||
-> ToBriDocM BriDocNumbered
|
||||
unknownNodeError infoStr ast = do
|
||||
mTell [ErrorUnknownNode infoStr ast]
|
||||
|
|
|
@ -20,16 +20,17 @@ import Language.Haskell.Brittany.Internal.Types
|
|||
|
||||
|
||||
layoutDataDecl
|
||||
:: Located (TyClDecl GhcPs)
|
||||
-> Located RdrName
|
||||
:: Data.Data.Data an1
|
||||
=> LocatedAn an1 (TyClDecl GhcPs)
|
||||
-> LocatedAn an2 RdrName
|
||||
-> LHsQTyVars GhcPs
|
||||
-> HsDataDefn GhcPs
|
||||
-> ToBriDocM BriDocNumbered
|
||||
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
||||
-- newtype MyType a b = MyType ..
|
||||
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
|
||||
HsDataDefn _ext NewType _ctxt _ctype Nothing [cons] mDerivs ->
|
||||
case cons of
|
||||
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
|
||||
(L _ (ConDeclH98 _ext consName False _qvars (Just (L _ [])) details _conDoc))
|
||||
-> docWrapNode ltycl $ do
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
consNameStr <- lrdrNameToTextAnn consName
|
||||
|
@ -54,9 +55,9 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
|||
|
||||
-- data MyData a b
|
||||
-- (zero constructors)
|
||||
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
|
||||
HsDataDefn _ext DataType mLhsContext _ctype Nothing [] mDerivs ->
|
||||
docWrapNode ltycl $ do
|
||||
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
|
||||
lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
tyVarLine <- return <$> createBndrDoc bndrs
|
||||
createDerivingPar mDerivs $ docSeq
|
||||
|
@ -68,11 +69,11 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
|||
|
||||
-- data MyData = MyData ..
|
||||
-- data MyData = MyData { .. }
|
||||
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
|
||||
HsDataDefn _ext DataType mLhsContext _ctype Nothing [cons] mDerivs ->
|
||||
case cons of
|
||||
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
|
||||
(L _ (ConDeclH98 _ext consName _hasExt qvars mRhsContext details _conDoc))
|
||||
-> docWrapNode ltycl $ do
|
||||
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
|
||||
lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
consNameStr <- lrdrNameToTextAnn consName
|
||||
tyVarLine <- return <$> createBndrDoc bndrs
|
||||
|
@ -81,7 +82,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
|||
Just x -> Just . pure <$> x
|
||||
rhsContextDocMay <- case mRhsContext of
|
||||
Nothing -> pure Nothing
|
||||
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
|
||||
Just lctxt -> Just . pure <$> createContextDoc (Just lctxt)
|
||||
rhsDoc <- return <$> createDetailsDoc consNameStr details
|
||||
consDoc <-
|
||||
fmap pure
|
||||
|
@ -200,11 +201,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
|||
|
||||
_ -> briDocByExactNoComment ltycl
|
||||
|
||||
createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
|
||||
createContextDoc [] = docEmpty
|
||||
createContextDoc [t] =
|
||||
docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
|
||||
createContextDoc (t1 : tR) = do
|
||||
createContextDoc :: Maybe (LHsContext GhcPs) -> ToBriDocM BriDocNumbered
|
||||
createContextDoc Nothing = docEmpty
|
||||
createContextDoc (Just (L _ lhsContext)) = case lhsContext of
|
||||
[] -> docEmpty
|
||||
[t] -> docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
|
||||
(t1 : tR) -> do
|
||||
t1Doc <- docSharedWrapper layoutType t1
|
||||
tRDocs <- tR `forM` docSharedWrapper layoutType
|
||||
docAlt
|
||||
|
@ -246,20 +248,20 @@ createBndrDoc bs = do
|
|||
createDerivingPar
|
||||
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
createDerivingPar derivs mainDoc = do
|
||||
case derivs of
|
||||
(L _ []) -> mainDoc
|
||||
(L _ types) ->
|
||||
docPar mainDoc
|
||||
$ docEnsureIndent BrIndentRegular
|
||||
$ docLines
|
||||
$ docWrapNode derivs
|
||||
$ docWrapNode (noLocA derivs)
|
||||
$ derivingClauseDoc
|
||||
<$> types
|
||||
<$> derivs
|
||||
|
||||
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
|
||||
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
|
||||
(L _ []) -> docSeq []
|
||||
(L _ ts) ->
|
||||
(L _ (DctSingle _ t)) -> derivingClauseDoc' [t]
|
||||
(L _ (DctMulti _ ts)) -> derivingClauseDoc' ts
|
||||
where
|
||||
derivingClauseDoc' [] = docSeq []
|
||||
derivingClauseDoc' ts =
|
||||
let
|
||||
tsLength = length ts
|
||||
whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
|
||||
|
@ -275,29 +277,32 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
|
|||
$ List.intersperse docCommaSep
|
||||
$ ts
|
||||
<&> \case
|
||||
HsIB _ t -> layoutType t
|
||||
_ -> undefined
|
||||
-- HsIB _ t -> layoutType t
|
||||
, whenMoreThan1Type ")"
|
||||
, rhsStrategy
|
||||
]
|
||||
where
|
||||
strategyLeftRight
|
||||
:: Located (DerivStrategy GhcPs)
|
||||
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
|
||||
strategyLeftRight = \case
|
||||
(L _ StockStrategy) -> (docLitS " stock", docEmpty)
|
||||
(L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)
|
||||
(L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)
|
||||
(L _ (StockStrategy _)) -> (docLitS " stock", docEmpty)
|
||||
(L _ (AnyclassStrategy _)) -> (docLitS " anyclass", docEmpty)
|
||||
(L _ (NewtypeStrategy _)) -> (docLitS " newtype", docEmpty)
|
||||
lVia@(L _ (ViaStrategy viaTypes)) ->
|
||||
( docEmpty
|
||||
, case viaTypes of
|
||||
HsIB _ext t ->
|
||||
docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
|
||||
XViaStrategyPs _epann (L _span (HsSig _sig _bndrs t)) ->
|
||||
docSeq [docWrapNode (reLocA lVia) $ docLitS " via", docSeparator, layoutType t]
|
||||
)
|
||||
|
||||
docDeriving :: ToBriDocM BriDocNumbered
|
||||
docDeriving = docLitS "deriving"
|
||||
|
||||
createDetailsDoc
|
||||
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
|
||||
:: Text -> HsConDeclH98Details GhcPs -> (ToBriDocM BriDocNumbered)
|
||||
createDetailsDoc consNameStr details = case details of
|
||||
PrefixCon args -> do
|
||||
PrefixCon _ args -> do
|
||||
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
|
||||
let
|
||||
singleLine = docSeq
|
||||
|
@ -421,9 +426,9 @@ createForallDoc lhsTyVarBndrs =
|
|||
|
||||
createNamesAndTypeDoc
|
||||
:: Data.Data.Data ast
|
||||
=> Located ast
|
||||
=> LocatedAn an1 ast
|
||||
-> [GenLocated t (FieldOcc GhcPs)]
|
||||
-> Located (HsType GhcPs)
|
||||
-> LocatedAn AnnListItem (HsType GhcPs)
|
||||
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
|
||||
createNamesAndTypeDoc lField names t =
|
||||
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
|
||||
|
|
|
@ -19,9 +19,9 @@ import GHC.Types.Basic
|
|||
( Activation(..)
|
||||
, InlinePragma(..)
|
||||
, InlineSpec(..)
|
||||
, LexicalFixity(..)
|
||||
, RuleMatchInfo(..)
|
||||
)
|
||||
import GHC.Types.Fixity (LexicalFixity(..))
|
||||
import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc)
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.ExactPrintUtils
|
||||
|
@ -35,12 +35,12 @@ import Language.Haskell.Brittany.Internal.Prelude
|
|||
import Language.Haskell.Brittany.Internal.PreludeUtils
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey)
|
||||
-- import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey)
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
|
||||
|
||||
import Language.Haskell.Brittany.Internal.EPCompat
|
||||
|
||||
|
||||
layoutDecl :: ToBriDoc HsDecl
|
||||
layoutDecl :: ToBriDoc AnnListItem HsDecl
|
||||
layoutDecl d@(L loc decl) = case decl of
|
||||
SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig)
|
||||
ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
|
||||
|
@ -57,9 +57,9 @@ layoutDecl d@(L loc decl) = case decl of
|
|||
-- Sig
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
layoutSig :: ToBriDoc Sig
|
||||
layoutSig :: ToBriDoc AnnListItem Sig
|
||||
layoutSig lsig@(L _loc sig) = case sig of
|
||||
TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ
|
||||
TypeSig _ names (HsWC _ (L _ (HsSig _ _ typ))) -> layoutNamesAndType Nothing names typ
|
||||
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
|
||||
docWrapNode lsig $ do
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
|
@ -80,8 +80,8 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
|
||||
<> nameStr
|
||||
<> Text.pack " #-}"
|
||||
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ
|
||||
PatSynSig _ names (HsIB _ typ) ->
|
||||
ClassOpSig _ False names (L _ (HsSig _ _ typ)) -> layoutNamesAndType Nothing names typ
|
||||
PatSynSig _ names (L _ (HsSig _ _ typ)) ->
|
||||
layoutNamesAndType (Just "pattern") names typ
|
||||
_ -> briDocByExactNoComment lsig -- TODO
|
||||
where
|
||||
|
@ -121,12 +121,12 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
specStringCompat
|
||||
:: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
|
||||
specStringCompat ast = \case
|
||||
NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""
|
||||
NoUserInlinePrag -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""
|
||||
Inline -> pure "INLINE "
|
||||
Inlinable -> pure "INLINABLE "
|
||||
NoInline -> pure "NOINLINE "
|
||||
|
||||
layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))
|
||||
layoutGuardLStmt :: ToBriDoc' an (Stmt GhcPs (LHsExpr GhcPs))
|
||||
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
|
||||
BodyStmt _ body _ _ -> layoutExpr body
|
||||
BindStmt _ lPat expr -> do
|
||||
|
@ -145,7 +145,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
layoutBind
|
||||
:: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)
|
||||
:: ToBriDocC an (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)
|
||||
layoutBind lbind@(L _ bind) = case bind of
|
||||
FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do
|
||||
idStr <- lrdrNameToTextAnn fId
|
||||
|
@ -160,7 +160,7 @@ layoutBind lbind@(L _ bind) = case bind of
|
|||
patDocs <- colsWrapPat =<< layoutPat pat
|
||||
clauseDocs <- layoutGrhs `mapM` grhss
|
||||
mWhereDocs <- layoutLocalBinds whereBinds
|
||||
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?
|
||||
let mWhereArg = mWhereDocs <&> (,) (undefined lbind) -- TODO: is this the right AnnKey?
|
||||
binderDoc <- docLit $ Text.pack "="
|
||||
hasComments <- hasAnyCommentsBelow lbind
|
||||
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal
|
||||
|
@ -173,7 +173,7 @@ layoutBind lbind@(L _ bind) = case bind of
|
|||
PatSynBind _ (PSB _ patID lpat rpat dir) -> do
|
||||
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat
|
||||
_ -> Right <$> unknownNodeError "" lbind
|
||||
layoutIPBind :: ToBriDoc IPBind
|
||||
layoutIPBind :: ToBriDoc an IPBind
|
||||
layoutIPBind lipbind@(L _ bind) = case bind of
|
||||
IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right"
|
||||
IPBind _ (Left (L _ (HsIPName name))) expr -> do
|
||||
|
@ -193,13 +193,14 @@ layoutIPBind lipbind@(L _ bind) = case bind of
|
|||
data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
|
||||
| BagSig (LSig GhcPs)
|
||||
|
||||
bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
|
||||
bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpanAnnA
|
||||
bindOrSigtoSrcSpan (BagBind (L l _)) = l
|
||||
bindOrSigtoSrcSpan (BagSig (L l _)) = l
|
||||
|
||||
layoutLocalBinds
|
||||
:: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
|
||||
layoutLocalBinds lbinds@(L _ binds) = case binds of
|
||||
:: HsLocalBindsLR GhcPs GhcPs -> ToBriDocM (Maybe [BriDocNumbered])
|
||||
-- :: ToBriDocC an (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
|
||||
layoutLocalBinds binds = case binds of
|
||||
-- HsValBinds (ValBindsIn lhsBindsLR []) ->
|
||||
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
|
||||
-- x@(HsValBinds (ValBindsIn{})) ->
|
||||
|
@ -209,8 +210,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
|
|||
unordered =
|
||||
[ BagBind b | b <- Data.Foldable.toList bindlrs ]
|
||||
++ [ BagSig s | s <- sigs ]
|
||||
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
|
||||
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
|
||||
ordered = List.sortOn (la2r . bindOrSigtoSrcSpan) unordered
|
||||
docs <- docWrapNode (noLocA binds) $ join <$> ordered `forM` \case
|
||||
BagBind b -> either id return <$> layoutBind b
|
||||
BagSig s -> return <$> layoutSig s
|
||||
return $ Just $ docs
|
||||
|
@ -225,7 +226,7 @@ layoutGrhs
|
|||
:: LGRHS GhcPs (LHsExpr GhcPs)
|
||||
-> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)
|
||||
layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do
|
||||
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
|
||||
guardDocs <- docWrapNode (reLocA lgrhs) $ layoutStmt `mapM` guards
|
||||
bodyDoc <- layoutExpr body
|
||||
return (guardDocs, bodyDoc, body)
|
||||
|
||||
|
@ -274,7 +275,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
|
|||
$ (List.intersperse docSeparator $ docForceSingleline <$> ps)
|
||||
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
|
||||
mWhereDocs <- layoutLocalBinds whereBinds
|
||||
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
|
||||
let mWhereArg = mWhereDocs <&> (,) ({-mkAnnKey-} undefined lmatch)
|
||||
let alignmentToken = if null pats then Nothing else funId
|
||||
hasComments <- hasAnyCommentsBelow lmatch
|
||||
layoutPatternBindFinal
|
||||
|
@ -307,7 +308,7 @@ layoutPatternBindFinal
|
|||
-> BriDocNumbered
|
||||
-> Maybe BriDocNumbered
|
||||
-> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)]
|
||||
-> Maybe (ExactPrint.AnnKey, [BriDocNumbered])
|
||||
-> Maybe (AnnKey, [BriDocNumbered])
|
||||
-- ^ AnnKey for the node that contains the AnnWhere position annotation
|
||||
-> Bool
|
||||
-> ToBriDocM BriDocNumbered
|
||||
|
@ -610,8 +611,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
|
|||
|
||||
-- | Layout a pattern synonym binding
|
||||
layoutPatSynBind
|
||||
:: Located (IdP GhcPs)
|
||||
-> HsPatSynDetails (Located (IdP GhcPs))
|
||||
:: LIdP GhcPs
|
||||
-> HsPatSynDetails GhcPs
|
||||
-> HsPatSynDir GhcPs
|
||||
-> LPat GhcPs
|
||||
-> ToBriDocM BriDocNumbered
|
||||
|
@ -663,10 +664,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do
|
|||
|
||||
-- | Helper method for the left hand side of a pattern synonym
|
||||
layoutLPatSyn
|
||||
:: Located (IdP GhcPs)
|
||||
-> HsPatSynDetails (Located (IdP GhcPs))
|
||||
:: LIdP GhcPs
|
||||
-> HsPatSynDetails GhcPs
|
||||
-> ToBriDocM BriDocNumbered
|
||||
layoutLPatSyn name (PrefixCon vars) = do
|
||||
layoutLPatSyn name (PrefixCon _ vars) = do
|
||||
docName <- lrdrNameToTextAnn name
|
||||
names <- mapM lrdrNameToTextAnn vars
|
||||
docSeq . fmap appSep $ docLit docName : (docLit <$> names)
|
||||
|
@ -677,7 +678,7 @@ layoutLPatSyn name (InfixCon left right) = do
|
|||
docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]
|
||||
layoutLPatSyn name (RecCon recArgs) = do
|
||||
docName <- lrdrNameToTextAnn name
|
||||
args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs
|
||||
args <- mapM (lrdrNameToTextAnn . rdrNameFieldOcc . recordPatSynField) recArgs
|
||||
docSeq
|
||||
. fmap docLit
|
||||
$ [docName, Text.pack " { "]
|
||||
|
@ -699,7 +700,7 @@ layoutPatSynWhere hs = case hs of
|
|||
-- TyClDecl
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
layoutTyCl :: ToBriDoc TyClDecl
|
||||
layoutTyCl :: Data.Data.Data an => ToBriDoc an TyClDecl
|
||||
layoutTyCl ltycl@(L _loc tycl) = case tycl of
|
||||
SynDecl _ name vars fixity typ -> do
|
||||
let
|
||||
|
@ -720,7 +721,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
|
|||
layoutSynDecl
|
||||
:: Bool
|
||||
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
|
||||
-> Located (IdP GhcPs)
|
||||
-> LIdP GhcPs
|
||||
-> [LHsTyVarBndr () GhcPs]
|
||||
-> LHsType GhcPs
|
||||
-> ToBriDocM BriDocNumbered
|
||||
|
@ -756,7 +757,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
|
|||
hasComments <- hasAnyCommentsConnected typ
|
||||
layoutLhsAndType hasComments sharedLhs "=" typeDoc
|
||||
|
||||
layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())
|
||||
layoutTyVarBndr :: Bool -> ToBriDoc an (HsTyVarBndr ())
|
||||
layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
|
||||
docWrapNodePrior lbndr $ case bndr of
|
||||
UserTyVar _ _ name -> do
|
||||
|
@ -783,13 +784,13 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
|
|||
layoutTyFamInstDecl
|
||||
:: Data.Data.Data a
|
||||
=> Bool
|
||||
-> Located a
|
||||
-> LocatedAn an a
|
||||
-> TyFamInstDecl GhcPs
|
||||
-> ToBriDocM BriDocNumbered
|
||||
layoutTyFamInstDecl inClass outerNode tfid = do
|
||||
let
|
||||
FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid
|
||||
-- bndrsMay isJust e.g. with
|
||||
FamEqn _ name bndrs pats _fixity typ = tfid_eqn tfid
|
||||
-- bndrs isJust e.g. with
|
||||
-- type instance forall a . MyType (Maybe a) = Either () a
|
||||
innerNode = outerNode
|
||||
docWrapNodePrior outerNode $ do
|
||||
|
@ -810,7 +811,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
|
|||
docWrapNode innerNode
|
||||
. docSeq
|
||||
$ [appSep instanceDoc]
|
||||
++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ]
|
||||
++ [ makeForallDoc foralls | HsOuterExplicit _ foralls <- [bndrs] ]
|
||||
++ [ docParenL | needsParens ]
|
||||
++ [appSep $ docWrapNode name $ docLit nameStr]
|
||||
++ intersperse docSeparator (layoutHsTyPats pats)
|
||||
|
@ -842,7 +843,7 @@ layoutHsTyPats pats = pats <&> \case
|
|||
-- Layout signatures and bindings using the corresponding layouters from the
|
||||
-- top-level. Layout the instance head, type family instances, and data family
|
||||
-- instances using ExactPrint.
|
||||
layoutClsInst :: ToBriDoc ClsInstDecl
|
||||
layoutClsInst :: Data.Data.Data an => ToBriDoc an ClsInstDecl
|
||||
layoutClsInst lcid@(L _ cid) = docLines
|
||||
[ layoutInstanceHead
|
||||
, docEnsureIndent BrIndentRegular
|
||||
|
@ -872,18 +873,18 @@ layoutClsInst lcid@(L _ cid) = docLines
|
|||
|
||||
-- | Like 'docLines', but sorts the lines based on location
|
||||
docSortedLines
|
||||
:: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
|
||||
:: [ToBriDocM (LocatedAn an BriDocNumbered)] -> ToBriDocM BriDocNumbered
|
||||
docSortedLines l =
|
||||
allocateNode
|
||||
. BDFLines
|
||||
. fmap unLoc
|
||||
. List.sortOn (ExactPrint.rs . getLoc)
|
||||
. List.sortOn (realSrcSpan . getLocA)
|
||||
=<< sequence l
|
||||
|
||||
layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)
|
||||
layoutAndLocateSig :: ToBriDocC AnnListItem (Sig GhcPs) (LocatedA BriDocNumbered)
|
||||
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig
|
||||
|
||||
layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered)
|
||||
layoutAndLocateBind :: ToBriDocC an (HsBind GhcPs) (LocatedAn an BriDocNumbered)
|
||||
layoutAndLocateBind lbind@(L loc _) =
|
||||
L loc <$> (joinBinds =<< layoutBind lbind)
|
||||
|
||||
|
@ -894,17 +895,17 @@ layoutClsInst lcid@(L _ cid) = docLines
|
|||
Right n -> return n
|
||||
|
||||
layoutAndLocateTyFamInsts
|
||||
:: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)
|
||||
:: ToBriDocC an (TyFamInstDecl GhcPs) (LocatedAn an BriDocNumbered)
|
||||
layoutAndLocateTyFamInsts ltfid@(L loc tfid) =
|
||||
L loc <$> layoutTyFamInstDecl True ltfid tfid
|
||||
|
||||
layoutAndLocateDataFamInsts
|
||||
:: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)
|
||||
:: Data.Data.Data an => ToBriDocC an (DataFamInstDecl GhcPs) (LocatedAn an BriDocNumbered)
|
||||
layoutAndLocateDataFamInsts ldfid@(L loc _) =
|
||||
L loc <$> layoutDataFamInstDecl ldfid
|
||||
|
||||
-- | Send to ExactPrint then remove unecessary whitespace
|
||||
layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl
|
||||
layoutDataFamInstDecl :: Data.Data.Data an => ToBriDoc an DataFamInstDecl
|
||||
layoutDataFamInstDecl ldfid =
|
||||
fmap stripWhitespace <$> briDocByExactNoComment ldfid
|
||||
|
||||
|
|
|
@ -8,12 +8,13 @@ import qualified Data.Data
|
|||
import qualified Data.Semigroup as Semigroup
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Text as Text
|
||||
import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan)
|
||||
import GHC (GenLocated(L), RdrName(..))
|
||||
import qualified GHC.Data.FastString as FastString
|
||||
import GHC.Hs
|
||||
import qualified GHC.OldList as List
|
||||
import GHC.Types.Basic
|
||||
import GHC.Types.Name
|
||||
import GHC.Types.SourceText
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.LayouterBasics
|
||||
import Language.Haskell.Brittany.Internal.Layouters.Decl
|
||||
|
@ -27,7 +28,7 @@ import Language.Haskell.Brittany.Internal.Utils
|
|||
|
||||
|
||||
|
||||
layoutExpr :: ToBriDoc HsExpr
|
||||
layoutExpr :: ToBriDoc AnnListItem HsExpr
|
||||
layoutExpr lexpr@(L _ expr) = do
|
||||
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
|
||||
let allowFreeIndent = indentPolicy == IndentPolicyFree
|
||||
|
@ -38,7 +39,7 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
HsRecFld{} -> do
|
||||
-- TODO
|
||||
briDocByExactInlineOnly "HsRecFld" lexpr
|
||||
HsOverLabel _ext _reboundFromLabel name ->
|
||||
HsOverLabel _ext name ->
|
||||
let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label
|
||||
HsIPVar _ext (HsIPName name) ->
|
||||
let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label
|
||||
|
@ -49,7 +50,7 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _)
|
||||
| pats <- m_pats match
|
||||
, GRHSs _ [lgrhs] llocals <- m_grhss match
|
||||
, L _ EmptyLocalBinds{} <- llocals
|
||||
, EmptyLocalBinds{} <- llocals
|
||||
, L _ (GRHS _ [] body) <- lgrhs
|
||||
-> do
|
||||
patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) ->
|
||||
|
@ -86,7 +87,7 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
[ docLit $ Text.pack "\\"
|
||||
, docWrapNode lmatch $ docForceSingleline funcPatternPartLine
|
||||
, appSep $ docLit $ Text.pack "->"
|
||||
, docWrapNode lgrhs $ docForceSingleline bodyDoc
|
||||
, docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc
|
||||
]
|
||||
-- double line
|
||||
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
||||
|
@ -97,13 +98,13 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
, docLit $ Text.pack "->"
|
||||
]
|
||||
)
|
||||
(docWrapNode lgrhs $ docForceSingleline bodyDoc)
|
||||
(docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc)
|
||||
-- wrapped par spacing
|
||||
, docSetParSpacing $ docSeq
|
||||
[ docLit $ Text.pack "\\"
|
||||
, docWrapNode lmatch $ docForceSingleline funcPatternPartLine
|
||||
, appSep $ docLit $ Text.pack "->"
|
||||
, docWrapNode lgrhs $ docForceParSpacing bodyDoc
|
||||
, docWrapNode (reLocA lgrhs) $ docForceParSpacing bodyDoc
|
||||
]
|
||||
-- conservative
|
||||
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
|
||||
|
@ -114,7 +115,7 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
, docLit $ Text.pack "->"
|
||||
]
|
||||
)
|
||||
(docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)
|
||||
(docWrapNode (reLocA lgrhs) $ docNonBottomSpacing bodyDoc)
|
||||
]
|
||||
HsLam{} -> unknownNodeError "HsLam too complex" lexpr
|
||||
HsLamCase _ (MG _ (L _ []) _) -> do
|
||||
|
@ -378,14 +379,14 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
ExplicitTuple _ args boxity -> do
|
||||
let
|
||||
argExprs = args <&> \arg -> case arg of
|
||||
(L _ (Present _ e)) -> (arg, Just e)
|
||||
(L _ (Missing NoExtField)) -> (arg, Nothing)
|
||||
(Present _ e) -> (arg, Just e)
|
||||
(Missing _) -> (arg, Nothing)
|
||||
argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) ->
|
||||
docWrapNode arg $ maybe docEmpty layoutExpr exprM
|
||||
docWrapNode (noLocA arg) $ maybe docEmpty layoutExpr exprM
|
||||
hasComments <-
|
||||
orM
|
||||
(hasCommentsBetween lexpr AnnOpenP AnnCloseP
|
||||
: map hasAnyCommentsBelow args
|
||||
: map (hasAnyCommentsBelow . noLocA) args
|
||||
)
|
||||
let
|
||||
(openLit, closeLit) = case boxity of
|
||||
|
@ -758,7 +759,7 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
_ -> do
|
||||
-- TODO
|
||||
unknownNodeError "HsDo{} unknown stmtCtx" lexpr
|
||||
ExplicitList _ _ elems@(_ : _) -> do
|
||||
ExplicitList _ elems@(_ : _) -> do
|
||||
elemDocs <- elems `forM` docSharedWrapper layoutExpr
|
||||
hasComments <- hasAnyCommentsBelow lexpr
|
||||
case splitFirstLast elemDocs of
|
||||
|
@ -800,12 +801,12 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
[docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]
|
||||
end = docLit $ Text.pack "]"
|
||||
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
|
||||
ExplicitList _ _ [] -> docLit $ Text.pack "[]"
|
||||
ExplicitList _ [] -> docLit $ Text.pack "[]"
|
||||
RecordCon _ lname fields -> case fields of
|
||||
HsRecFields fs Nothing -> do
|
||||
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
|
||||
rFs <-
|
||||
fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do
|
||||
fs `forM` \lfield@(L _ (HsRecField _ (L _ fieldOcc) rFExpr pun)) -> do
|
||||
let FieldOcc _ lnameF = fieldOcc
|
||||
rFExpDoc <- if pun
|
||||
then return Nothing
|
||||
|
@ -818,7 +819,7 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do
|
||||
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
|
||||
fieldDocs <-
|
||||
fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do
|
||||
fs `forM` \fieldl@(L _ (HsRecField _ (L _ fieldOcc) fExpr pun)) -> do
|
||||
let FieldOcc _ lnameF = fieldOcc
|
||||
fExpDoc <- if pun
|
||||
then return Nothing
|
||||
|
@ -826,10 +827,10 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
return (fieldl, lrdrNameToText lnameF, fExpDoc)
|
||||
recordExpression True indentPolicy lexpr nameDoc fieldDocs
|
||||
_ -> unknownNodeError "RecordCon with puns" lexpr
|
||||
RecordUpd _ rExpr fields -> do
|
||||
RecordUpd _ rExpr (Left fields) -> do
|
||||
rExprDoc <- docSharedWrapper layoutExpr rExpr
|
||||
rFs <-
|
||||
fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do
|
||||
fields `forM` \lfield@(L _ (HsRecField _ (L _ ambName) rFExpr pun)) -> do
|
||||
rFExpDoc <- if pun
|
||||
then return Nothing
|
||||
else Just <$> docSharedWrapper layoutExpr rFExpr
|
||||
|
@ -837,7 +838,11 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
|
||||
Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
|
||||
recordExpression False indentPolicy lexpr rExprDoc rFs
|
||||
ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do
|
||||
RecordUpd _ _rExpr (Right _projections) -> do
|
||||
-- TODO
|
||||
briDocByExactInlineOnly "RecordUpd _ _ (Right _projections)" lexpr
|
||||
|
||||
ExprWithTySig _ exp1 (HsWC _ (L _ (HsSig _ _ typ1))) -> do
|
||||
expDoc <- docSharedWrapper layoutExpr exp1
|
||||
typDoc <- docSharedWrapper layoutType typ1
|
||||
docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc]
|
||||
|
@ -925,14 +930,21 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
HsPragE{} -> do
|
||||
-- TODO
|
||||
briDocByExactInlineOnly "HsPragE{}" lexpr
|
||||
HsGetField{} -> do
|
||||
-- TODO
|
||||
briDocByExactInlineOnly "HsGetField{}" lexpr
|
||||
HsProjection{} -> do
|
||||
-- TODO
|
||||
briDocByExactInlineOnly "HsProjection{}" lexpr
|
||||
|
||||
|
||||
recordExpression
|
||||
:: (Data.Data.Data lExpr, Data.Data.Data name)
|
||||
=> Bool
|
||||
-> IndentPolicy
|
||||
-> GenLocated SrcSpan lExpr
|
||||
-> LocatedAn an1 lExpr
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> [ ( GenLocated SrcSpan name
|
||||
-> [ ( LocatedAn an2 name
|
||||
, Text
|
||||
, Maybe (ToBriDocM BriDocNumbered)
|
||||
)
|
||||
|
@ -1073,14 +1085,14 @@ litBriDoc = \case
|
|||
HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t
|
||||
HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
|
||||
HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
|
||||
HsRat _ (FL (SourceText t) _ _ _ _) _type -> BDFLit $ Text.pack t
|
||||
HsFloatPrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
|
||||
HsDoublePrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
|
||||
_ -> error "litBriDoc: literal with no SourceText"
|
||||
|
||||
overLitValBriDoc :: OverLitVal -> BriDocFInt
|
||||
overLitValBriDoc = \case
|
||||
HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t
|
||||
HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
|
||||
HsFractional (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
|
||||
HsIsString (SourceText t) _ -> BDFLit $ Text.pack t
|
||||
_ -> error "overLitValBriDoc: literal with no SourceText"
|
||||
|
|
|
@ -7,9 +7,7 @@ import Language.Haskell.Brittany.Internal.Types
|
|||
|
||||
|
||||
|
||||
layoutExpr :: ToBriDoc HsExpr
|
||||
|
||||
-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
|
||||
layoutExpr :: ToBriDoc AnnListItem HsExpr
|
||||
|
||||
litBriDoc :: HsLit GhcPs -> BriDocFInt
|
||||
|
||||
|
|
|
@ -23,17 +23,17 @@ import Language.Haskell.Brittany.Internal.Utils
|
|||
|
||||
|
||||
|
||||
prepareName :: LIEWrappedName name -> Located name
|
||||
prepareName :: LIEWrappedName name -> LocatedN name
|
||||
prepareName = ieLWrappedName
|
||||
|
||||
layoutIE :: ToBriDoc IE
|
||||
layoutIE :: ToBriDoc an IE
|
||||
layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
|
||||
IEVar _ x -> layoutWrapped lie x
|
||||
IEThingAbs _ x -> layoutWrapped lie x
|
||||
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
|
||||
IEThingWith _ x (IEWildcard _) _ _ ->
|
||||
IEThingWith _ x (IEWildcard _) _ ->
|
||||
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
|
||||
IEThingWith _ x _ ns _ -> do
|
||||
IEThingWith _ x _ ns -> do
|
||||
hasComments <- orM
|
||||
(hasCommentsBetween lie AnnOpenP AnnCloseP
|
||||
: hasAnyCommentsBelow x
|
||||
|
@ -78,10 +78,10 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
|
|||
where
|
||||
layoutWrapped _ = \case
|
||||
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
|
||||
L _ (IEPattern n) -> do
|
||||
L _ (IEPattern _ n) -> do
|
||||
name <- lrdrNameToTextAnn n
|
||||
docLit $ Text.pack "pattern " <> name
|
||||
L _ (IEType n) -> do
|
||||
L _ (IEType _ n) -> do
|
||||
name <- lrdrNameToTextAnn n
|
||||
docLit $ Text.pack "type " <> name
|
||||
|
||||
|
@ -95,7 +95,7 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
|
|||
-- left to the caller since that is context sensitive
|
||||
layoutAnnAndSepLLIEs
|
||||
:: SortItemsFlag
|
||||
-> Located [LIE GhcPs]
|
||||
-> LocatedAn an [LIE GhcPs]
|
||||
-> ToBriDocM [ToBriDocM BriDocNumbered]
|
||||
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
|
||||
let makeIENode ie = docSeq [docCommaSep, ie]
|
||||
|
@ -131,7 +131,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
|
|||
isProperIEThing = \case
|
||||
L _ (IEThingAbs _ _wn) -> True
|
||||
L _ (IEThingAll _ _wn) -> True
|
||||
L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True
|
||||
L _ (IEThingWith _ _wn NoIEWildcard _) -> True
|
||||
_ -> False
|
||||
isIEVar :: LIE GhcPs -> Bool
|
||||
isIEVar = \case
|
||||
|
@ -143,7 +143,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
|
|||
thingFolder _ l2@(L _ IEThingAll{}) = l2
|
||||
thingFolder l1 (L _ IEThingAbs{}) = l1
|
||||
thingFolder (L _ IEThingAbs{}) l2 = l2
|
||||
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
|
||||
thingFolder (L l (IEThingWith x wn _ consItems1)) (L _ (IEThingWith _ _ _ consItems2))
|
||||
= L
|
||||
l
|
||||
(IEThingWith
|
||||
|
@ -151,7 +151,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
|
|||
wn
|
||||
NoIEWildcard
|
||||
(consItems1 ++ consItems2)
|
||||
(fieldLbls1 ++ fieldLbls2)
|
||||
)
|
||||
thingFolder _ _ =
|
||||
error "thingFolder should be exhaustive because we have a guard above"
|
||||
|
@ -171,7 +170,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
|
|||
-- ( -- a comment
|
||||
-- )
|
||||
layoutLLIEs
|
||||
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
|
||||
:: Bool -> SortItemsFlag -> LocatedAn an [LIE GhcPs] -> ToBriDocM BriDocNumbered
|
||||
layoutLLIEs enableSingleline shouldSort llies = do
|
||||
ieDs <- layoutAnnAndSepLLIEs shouldSort llies
|
||||
hasComments <- hasAnyCommentsBelow llies
|
||||
|
@ -199,8 +198,8 @@ layoutLLIEs enableSingleline shouldSort llies = do
|
|||
wrappedNameToText :: LIEWrappedName RdrName -> Text
|
||||
wrappedNameToText = \case
|
||||
L _ (IEName n) -> lrdrNameToText n
|
||||
L _ (IEPattern n) -> lrdrNameToText n
|
||||
L _ (IEType n) -> lrdrNameToText n
|
||||
L _ (IEPattern _ n) -> lrdrNameToText n
|
||||
L _ (IEType _ n) -> lrdrNameToText n
|
||||
|
||||
-- | Returns a "fingerprint string", not a full text representation, nor even
|
||||
-- a source code representation of this syntax node.
|
||||
|
@ -210,7 +209,7 @@ lieToText = \case
|
|||
L _ (IEVar _ wn) -> wrappedNameToText wn
|
||||
L _ (IEThingAbs _ wn) -> wrappedNameToText wn
|
||||
L _ (IEThingAll _ wn) -> wrappedNameToText wn
|
||||
L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
|
||||
L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn
|
||||
-- TODO: These _may_ appear in exports!
|
||||
-- Need to check, and either put them at the top (for module) or do some
|
||||
-- other clever thing.
|
||||
|
@ -219,6 +218,6 @@ lieToText = \case
|
|||
L _ IEDoc{} -> Text.pack "@IEDoc"
|
||||
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
|
||||
where
|
||||
moduleNameToText :: Located ModuleName -> Text
|
||||
moduleNameToText :: LocatedAn an ModuleName -> Text
|
||||
moduleNameToText (L _ name) =
|
||||
Text.pack ("@IEModuleContents" ++ moduleNameString name)
|
||||
|
|
|
@ -7,6 +7,7 @@ import qualified Data.Text as Text
|
|||
import GHC (GenLocated(L), Located, moduleNameString, unLoc)
|
||||
import GHC.Hs
|
||||
import GHC.Types.Basic
|
||||
import qualified GHC.Types.SourceText
|
||||
import GHC.Unit.Types (IsBootInterface(..))
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.LayouterBasics
|
||||
|
@ -17,13 +18,13 @@ import Language.Haskell.Brittany.Internal.Types
|
|||
|
||||
|
||||
|
||||
prepPkg :: SourceText -> String
|
||||
prepPkg :: GHC.Types.SourceText.SourceText -> String
|
||||
prepPkg rawN = case rawN of
|
||||
SourceText n -> n
|
||||
GHC.Types.SourceText.SourceText n -> n
|
||||
-- This would be odd to encounter and the
|
||||
-- result will most certainly be wrong
|
||||
NoSourceText -> ""
|
||||
prepModName :: Located e -> e
|
||||
GHC.Types.SourceText.NoSourceText -> ""
|
||||
prepModName :: LocatedAn an e -> e
|
||||
prepModName = unLoc
|
||||
|
||||
layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
|
||||
|
@ -36,7 +37,7 @@ layoutImport importD = case importD of
|
|||
let
|
||||
compact = indentPolicy /= IndentPolicyFree
|
||||
modNameT = Text.pack $ moduleNameString modName
|
||||
pkgNameT = Text.pack . prepPkg . sl_st <$> pkg
|
||||
pkgNameT = Text.pack . prepPkg . GHC.Types.SourceText.sl_st <$> pkg
|
||||
masT = Text.pack . moduleNameString . prepModName <$> mas
|
||||
hiding = maybe False fst mllies
|
||||
minQLength = length "import qualified "
|
||||
|
|
|
@ -18,20 +18,21 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
|
|||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import Language.Haskell.GHC.ExactPrint.Types
|
||||
(DeltaPos(..), commentContents, deltaRow)
|
||||
(commentContents)
|
||||
|
||||
import Language.Haskell.Brittany.Internal.EPCompat (Annotation)
|
||||
|
||||
|
||||
|
||||
layoutModule :: ToBriDoc' HsModule
|
||||
layoutModule :: ToBriDoc' an HsModule
|
||||
layoutModule lmod@(L _ mod') = case mod' of
|
||||
-- Implicit module Main
|
||||
HsModule _ Nothing _ imports _ _ _ -> do
|
||||
HsModule _ _ Nothing _ imports _ _ _ -> do
|
||||
commentedImports <- transformToCommentedImport imports
|
||||
-- groupify commentedImports `forM_` tellDebugMessShow
|
||||
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
|
||||
-- sortedImports <- sortImports imports
|
||||
-- docLines $ [layoutImport y i | (y, i) <- sortedImports]
|
||||
HsModule _ (Just n) les imports _ _ _ -> do
|
||||
HsModule _ _ (Just n) les imports _ _ _ -> do
|
||||
commentedImports <- transformToCommentedImport imports
|
||||
-- groupify commentedImports `forM_` tellDebugMessShow
|
||||
-- sortedImports <- sortImports imports
|
||||
|
@ -99,11 +100,12 @@ transformToCommentedImport
|
|||
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
|
||||
transformToCommentedImport is = do
|
||||
nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do
|
||||
annotionMay <- astAnn i
|
||||
annotionMay <- undefined -- astAnn i
|
||||
pure (annotionMay, rawImport)
|
||||
let
|
||||
convertComment (c, DP (y, x)) =
|
||||
replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
|
||||
convertComment (c, _ {-DP (y, x)-}) =
|
||||
undefined
|
||||
-- replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
|
||||
accumF
|
||||
:: [(Comment, DeltaPos)]
|
||||
-> (Maybe Annotation, ImportDecl GhcPs)
|
||||
|
@ -120,21 +122,22 @@ transformToCommentedImport is = do
|
|||
)
|
||||
Just ann ->
|
||||
let
|
||||
blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1
|
||||
blanksBeforeImportDecl = undefined -- deltaRow (annEntryDelta ann) - 1
|
||||
(newAccumulator, priorComments') =
|
||||
List.span ((== 0) . deltaRow . snd) (annPriorComments ann)
|
||||
List.span ((== 0) . {-deltaRow-} undefined . snd) ({-annPriorComments-} undefined ann)
|
||||
go
|
||||
:: [(Comment, DeltaPos)]
|
||||
-> [(Comment, DeltaPos)]
|
||||
-> ([CommentedImport], [(Comment, DeltaPos)], Int)
|
||||
go acc [] = ([], acc, 0)
|
||||
go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
|
||||
go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
|
||||
go acc ((c1, DP (y, x)) : xs) =
|
||||
( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
|
||||
, (c1, DP (1, x)) : acc
|
||||
, 0
|
||||
)
|
||||
go acc _ = undefined
|
||||
-- go acc [c1@(_, {DP (y, _)})] = ([], c1 : acc, y - 1)
|
||||
-- go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
|
||||
-- go acc ((c1, DP (y, x)) : xs) =
|
||||
-- ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
|
||||
-- , (c1, DP (1, x)) : acc
|
||||
-- , 0
|
||||
-- )
|
||||
(convertedIndependentComments, beforeComments, initialBlanks) =
|
||||
if blanksBeforeImportDecl /= 0
|
||||
then (convertComment =<< priorComments', [], 0)
|
||||
|
@ -194,4 +197,5 @@ commentedImportsToDoc = \case
|
|||
ImportStatement r -> docSeq
|
||||
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
|
||||
where
|
||||
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)
|
||||
commentToDoc (c, _ {-DP (_y, x)-}) = undefined
|
||||
-- docLitS (replicate x ' ' ++ commentContents c)
|
||||
|
|
|
@ -57,7 +57,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
|
|||
-- x1' <- docSeq [docLit $ Text.pack "(", return x1]
|
||||
-- xN' <- docSeq [return xN, docLit $ Text.pack ")"]
|
||||
-- return $ (x1' Seq.<| middle) Seq.|> xN'
|
||||
ConPat _ lname (PrefixCon args) -> do
|
||||
ConPat _ lname (PrefixCon _tyargs args) -> do
|
||||
-- Abc a b c -> expr
|
||||
nameDoc <- lrdrNameToTextAnn lname
|
||||
argDocs <- layoutPat `mapM` args
|
||||
|
@ -84,7 +84,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
|
|||
-- Abc { a = locA, b = locB, c = locC } -> expr1
|
||||
-- Abc { a, b, c } -> expr2
|
||||
let t = lrdrNameToText lname
|
||||
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
|
||||
fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
|
||||
let FieldOcc _ lnameF = fieldOcc
|
||||
fExpDoc <- if pun
|
||||
then return Nothing
|
||||
|
@ -111,7 +111,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
|
|||
| dotdoti == length fs -> do
|
||||
-- Abc { a = locA, .. }
|
||||
let t = lrdrNameToText lname
|
||||
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
|
||||
fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
|
||||
let FieldOcc _ lnameF = fieldOcc
|
||||
fExpDoc <- if pun
|
||||
then return Nothing
|
||||
|
@ -171,7 +171,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
|
|||
wrapPatPrepend pat1 (docLit $ Text.pack "~")
|
||||
NPat _ llit@(L _ ol) mNegative _ -> do
|
||||
-- -13 -> expr
|
||||
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
|
||||
litDoc <- docWrapNode (reLocA llit) $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
|
||||
negDoc <- docLit $ Text.pack "-"
|
||||
pure $ case mNegative of
|
||||
Just{} -> Seq.fromList [negDoc, litDoc]
|
||||
|
|
|
@ -19,7 +19,7 @@ import Language.Haskell.Brittany.Internal.Types
|
|||
|
||||
|
||||
|
||||
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
|
||||
layoutStmt :: ToBriDoc' AnnListItem (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
|
||||
layoutStmt lstmt@(L _ stmt) = do
|
||||
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
|
||||
indentAmount :: Int <-
|
||||
|
@ -94,7 +94,7 @@ layoutStmt lstmt@(L _ stmt) = do
|
|||
$ docPar
|
||||
(docLit $ Text.pack "let")
|
||||
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
|
||||
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
|
||||
RecStmt _ (L _ stmts) _ _ _ _ _ -> runFilteredAlternative $ do
|
||||
-- rec stmt1
|
||||
-- stmt2
|
||||
-- stmt3
|
||||
|
|
|
@ -7,4 +7,4 @@ import Language.Haskell.Brittany.Internal.Types
|
|||
|
||||
|
||||
|
||||
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
|
||||
layoutStmt :: ToBriDoc' AnnListItem (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
|
||||
|
|
|
@ -1,13 +1,15 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.Layouters.Type where
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import GHC (AnnKeywordId(..), GenLocated(L))
|
||||
import GHC (GenLocated(L))
|
||||
import GHC.Hs
|
||||
import qualified GHC.OldList as List
|
||||
import GHC.Types.Basic
|
||||
import qualified GHC.Types.SourceText
|
||||
import GHC.Utils.Outputable (ftext, showSDocUnsafe)
|
||||
import Language.Haskell.Brittany.Internal.LayouterBasics
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
|
@ -17,8 +19,8 @@ import Language.Haskell.Brittany.Internal.Utils
|
|||
(FirstLastView(..), splitFirstLast)
|
||||
|
||||
|
||||
|
||||
layoutType :: ToBriDoc HsType
|
||||
--- XXX: maybe push `Anno (sym GhcPs)` into ToBriDoc definition in place of a typevar
|
||||
layoutType :: ToBriDoc AnnListItem HsType
|
||||
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
||||
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
|
||||
HsTyVar _ promoted name -> do
|
||||
|
@ -26,7 +28,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
case promoted of
|
||||
IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
|
||||
NotPromoted -> docWrapNode name $ docLit t
|
||||
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
|
||||
HsForAllTy _ hsf (L _ (HsQualTy _ (fromMaybeContext -> cntxts) typ2)) -> do
|
||||
let bndrs = getBinders hsf
|
||||
typeDoc <- docSharedWrapper layoutType typ2
|
||||
tyVarDocs <- layoutTyVarBndrs bndrs
|
||||
|
@ -159,7 +161,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
]
|
||||
)
|
||||
]
|
||||
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
|
||||
HsQualTy _ (fromMaybe (noLocA []) -> lcntxts@(L _ cntxts)) typ1 -> do
|
||||
typeDoc <- docSharedWrapper layoutType typ1
|
||||
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
|
||||
let
|
||||
|
@ -291,8 +293,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
]
|
||||
HsTupleTy _ tupleSort typs -> case tupleSort of
|
||||
HsUnboxedTuple -> unboxed
|
||||
HsBoxedTuple -> simple
|
||||
HsConstraintTuple -> simple
|
||||
HsBoxedOrConstraintTuple -> simple
|
||||
where
|
||||
unboxed = if null typs
|
||||
|
@ -573,11 +573,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
|
|||
HsExplicitTupleTy{} -> -- TODO
|
||||
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
|
||||
HsTyLit _ lit -> case lit of
|
||||
HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
|
||||
HsNumTy NoSourceText _ ->
|
||||
HsNumTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
|
||||
HsNumTy GHC.Types.SourceText.NoSourceText _ ->
|
||||
error "overLitValBriDoc: literal with no SourceText"
|
||||
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
|
||||
HsStrTy NoSourceText _ ->
|
||||
HsStrTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
|
||||
HsStrTy GHC.Types.SourceText.NoSourceText _ ->
|
||||
error "overLitValBriDoc: literal with no SourceText"
|
||||
HsCharTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
|
||||
HsCharTy GHC.Types.SourceText.NoSourceText _ ->
|
||||
error "overLitValBriDoc: literal with no SourceText"
|
||||
HsWildCardTy _ -> docLit $ Text.pack "_"
|
||||
HsSumTy{} -> -- TODO
|
||||
|
@ -622,14 +625,12 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
|
|||
, docLit $ Text.pack ")"
|
||||
]
|
||||
|
||||
getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass]
|
||||
getBinders :: HsForAllTelescope (GhcPass pass) -> [LHsTyVarBndr () (GhcPass pass)]
|
||||
getBinders x = case x of
|
||||
HsForAllVis _ b -> b
|
||||
HsForAllInvis _ b -> fmap withoutSpecificity b
|
||||
XHsForAllTelescope _ -> []
|
||||
|
||||
withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass
|
||||
withoutSpecificity :: LHsTyVarBndr flag (GhcPass pass) -> LHsTyVarBndr () (GhcPass pass)
|
||||
withoutSpecificity = fmap $ \case
|
||||
UserTyVar a _ c -> UserTyVar a () c
|
||||
KindedTyVar a _ c d -> KindedTyVar a () c d
|
||||
XTyVarBndr a -> XTyVarBndr a
|
||||
|
|
|
@ -13,11 +13,11 @@ import qualified GHC.Driver.Session
|
|||
import qualified GHC.Parser.Header
|
||||
import qualified GHC.Platform
|
||||
import qualified GHC.Settings
|
||||
import qualified GHC.Types.SafeHaskell
|
||||
import qualified GHC.Types.SrcLoc
|
||||
import qualified GHC.Utils.Error
|
||||
import qualified GHC.Utils.Fingerprint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||
|
||||
-- | Parses a Haskell module. Although this nominally requires IO, it is
|
||||
-- morally pure. It should have no observable effects.
|
||||
|
@ -27,7 +27,7 @@ parseModule
|
|||
-> FilePath
|
||||
-> (GHC.Driver.Session.DynFlags -> io (Either String a))
|
||||
-> String
|
||||
-> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
|
||||
-> io (Either String (GHC.ParsedSource, a))
|
||||
parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
|
||||
let
|
||||
dynFlags1 = GHC.Driver.Session.gopt_set
|
||||
|
@ -36,7 +36,7 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
|
|||
-- Neither passing in @"-XUnsafe"@ as a command line argument nor having
|
||||
-- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
|
||||
initialDynFlags
|
||||
{ GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe
|
||||
{ GHC.Driver.Session.safeHaskell = GHC.Types.SafeHaskell.Sf_Unsafe
|
||||
}
|
||||
GHC.Driver.Session.Opt_KeepRawTokenStream
|
||||
(dynFlags2, leftovers1, _) <-
|
||||
|
@ -56,7 +56,7 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
|
|||
ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
|
||||
case parseResult of
|
||||
Left errorMessages -> handleErrorMessages errorMessages
|
||||
Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult)
|
||||
Right parsedSource -> pure (parsedSource, dynFlagsResult)
|
||||
|
||||
handleLeftovers
|
||||
:: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()
|
||||
|
@ -79,7 +79,6 @@ initialSettings = GHC.Driver.Session.Settings
|
|||
, GHC.Driver.Session.sTargetPlatform = initialTargetPlatform
|
||||
, GHC.Driver.Session.sToolSettings = initialToolSettings
|
||||
, GHC.Driver.Session.sPlatformMisc = initialPlatformMisc
|
||||
, GHC.Driver.Session.sPlatformConstants = initialPlatformConstants
|
||||
, GHC.Driver.Session.sRawSettings = []
|
||||
}
|
||||
|
||||
|
@ -101,10 +100,8 @@ initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion
|
|||
|
||||
initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
|
||||
initialPlatformMisc = GHC.Driver.Session.PlatformMisc
|
||||
{ GHC.Driver.Session.platformMisc_ghcDebugged = False
|
||||
, GHC.Driver.Session.platformMisc_ghcRTSWays = ""
|
||||
{ GHC.Driver.Session.platformMisc_ghcRTSWays = ""
|
||||
, GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False
|
||||
, GHC.Driver.Session.platformMisc_ghcThreaded = False
|
||||
, GHC.Driver.Session.platformMisc_ghcWithInterpreter = False
|
||||
, GHC.Driver.Session.platformMisc_ghcWithSMP = False
|
||||
, GHC.Driver.Session.platformMisc_libFFI = False
|
||||
|
@ -118,143 +115,142 @@ initialLlvmConfig = GHC.Driver.Session.LlvmConfig
|
|||
, GHC.Driver.Session.llvmTargets = []
|
||||
}
|
||||
|
||||
initialPlatformConstants :: GHC.Settings.PlatformConstants
|
||||
initialPlatformConstants = GHC.Settings.PlatformConstants
|
||||
{ GHC.Settings.pc_AP_STACK_SPLIM = 0
|
||||
, GHC.Settings.pc_BITMAP_BITS_SHIFT = 0
|
||||
, GHC.Settings.pc_BLOCK_SIZE = 0
|
||||
, GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0
|
||||
, GHC.Settings.pc_CINT_SIZE = 0
|
||||
, GHC.Settings.pc_CLONG_LONG_SIZE = 0
|
||||
, GHC.Settings.pc_CLONG_SIZE = 0
|
||||
, GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0
|
||||
, GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False
|
||||
, GHC.Settings.pc_ILDV_CREATE_MASK = 0
|
||||
, GHC.Settings.pc_ILDV_STATE_CREATE = 0
|
||||
, GHC.Settings.pc_ILDV_STATE_USE = 0
|
||||
, GHC.Settings.pc_LDV_SHIFT = 0
|
||||
, GHC.Settings.pc_MAX_CHARLIKE = 0
|
||||
, GHC.Settings.pc_MAX_Double_REG = 0
|
||||
, GHC.Settings.pc_MAX_Float_REG = 0
|
||||
, GHC.Settings.pc_MAX_INTLIKE = 0
|
||||
, GHC.Settings.pc_MAX_Long_REG = 0
|
||||
, GHC.Settings.pc_MAX_Real_Double_REG = 0
|
||||
, GHC.Settings.pc_MAX_Real_Float_REG = 0
|
||||
, GHC.Settings.pc_MAX_Real_Long_REG = 0
|
||||
, GHC.Settings.pc_MAX_Real_Vanilla_REG = 0
|
||||
, GHC.Settings.pc_MAX_Real_XMM_REG = 0
|
||||
, GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0
|
||||
, GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0
|
||||
, GHC.Settings.pc_MAX_Vanilla_REG = 0
|
||||
, GHC.Settings.pc_MAX_XMM_REG = 0
|
||||
, GHC.Settings.pc_MIN_CHARLIKE = 0
|
||||
, GHC.Settings.pc_MIN_INTLIKE = 0
|
||||
, GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0
|
||||
, GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0
|
||||
, GHC.Settings.pc_OFFSET_bdescr_blocks = 0
|
||||
, GHC.Settings.pc_OFFSET_bdescr_flags = 0
|
||||
, GHC.Settings.pc_OFFSET_bdescr_free = 0
|
||||
, GHC.Settings.pc_OFFSET_bdescr_start = 0
|
||||
, GHC.Settings.pc_OFFSET_Capability_r = 0
|
||||
, GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0
|
||||
, GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0
|
||||
, GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0
|
||||
, GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0
|
||||
, GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0
|
||||
, GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0
|
||||
, GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0
|
||||
, GHC.Settings.pc_OFFSET_StgEntCounter_link = 0
|
||||
, GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0
|
||||
, GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
|
||||
, GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0
|
||||
, GHC.Settings.pc_OFFSET_stgGCEnter1 = 0
|
||||
, GHC.Settings.pc_OFFSET_stgGCFun = 0
|
||||
, GHC.Settings.pc_OFFSET_StgHeader_ccs = 0
|
||||
, GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0
|
||||
, GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0
|
||||
, GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0
|
||||
, GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
|
||||
, GHC.Settings.pc_OFFSET_StgStack_sp = 0
|
||||
, GHC.Settings.pc_OFFSET_StgStack_stack = 0
|
||||
, GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0
|
||||
, GHC.Settings.pc_OFFSET_StgTSO_cccs = 0
|
||||
, GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0
|
||||
, GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0
|
||||
, GHC.Settings.pc_PROF_HDR_SIZE = 0
|
||||
, GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0
|
||||
, GHC.Settings.pc_REP_CostCentreStack_scc_count = 0
|
||||
, GHC.Settings.pc_REP_StgEntCounter_allocd = 0
|
||||
, GHC.Settings.pc_REP_StgEntCounter_allocs = 0
|
||||
, GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0
|
||||
, GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0
|
||||
, GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0
|
||||
, GHC.Settings.pc_RESERVED_STACK_WORDS = 0
|
||||
, GHC.Settings.pc_SIZEOF_CostCentreStack = 0
|
||||
, GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0
|
||||
, GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0
|
||||
, GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
|
||||
, GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
|
||||
, GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0
|
||||
, GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
|
||||
, GHC.Settings.pc_STD_HDR_SIZE = 0
|
||||
, GHC.Settings.pc_TAG_BITS = 0
|
||||
, GHC.Settings.pc_TICKY_BIN_COUNT = 0
|
||||
, GHC.Settings.pc_WORD_SIZE = 0
|
||||
initialPlatformConstants :: GHC.Platform.PlatformConstants
|
||||
initialPlatformConstants = GHC.Platform.PlatformConstants
|
||||
{ GHC.Platform.pc_AP_STACK_SPLIM = 0
|
||||
, GHC.Platform.pc_BITMAP_BITS_SHIFT = 0
|
||||
, GHC.Platform.pc_BLOCK_SIZE = 0
|
||||
, GHC.Platform.pc_BLOCKS_PER_MBLOCK = 0
|
||||
, GHC.Platform.pc_CINT_SIZE = 0
|
||||
, GHC.Platform.pc_CLONG_LONG_SIZE = 0
|
||||
, GHC.Platform.pc_CLONG_SIZE = 0
|
||||
, GHC.Platform.pc_CONTROL_GROUP_CONST_291 = 0
|
||||
, GHC.Platform.pc_ILDV_CREATE_MASK = 0
|
||||
, GHC.Platform.pc_ILDV_STATE_CREATE = 0
|
||||
, GHC.Platform.pc_ILDV_STATE_USE = 0
|
||||
, GHC.Platform.pc_LDV_SHIFT = 0
|
||||
, GHC.Platform.pc_MAX_CHARLIKE = 0
|
||||
, GHC.Platform.pc_MAX_Double_REG = 0
|
||||
, GHC.Platform.pc_MAX_Float_REG = 0
|
||||
, GHC.Platform.pc_MAX_INTLIKE = 0
|
||||
, GHC.Platform.pc_MAX_Long_REG = 0
|
||||
, GHC.Platform.pc_MAX_Real_Double_REG = 0
|
||||
, GHC.Platform.pc_MAX_Real_Float_REG = 0
|
||||
, GHC.Platform.pc_MAX_Real_Long_REG = 0
|
||||
, GHC.Platform.pc_MAX_Real_Vanilla_REG = 0
|
||||
, GHC.Platform.pc_MAX_Real_XMM_REG = 0
|
||||
, GHC.Platform.pc_MAX_SPEC_AP_SIZE = 0
|
||||
, GHC.Platform.pc_MAX_SPEC_SELECTEE_SIZE = 0
|
||||
, GHC.Platform.pc_MAX_Vanilla_REG = 0
|
||||
, GHC.Platform.pc_MAX_XMM_REG = 0
|
||||
, GHC.Platform.pc_MIN_CHARLIKE = 0
|
||||
, GHC.Platform.pc_MIN_INTLIKE = 0
|
||||
, GHC.Platform.pc_MIN_PAYLOAD_SIZE = 0
|
||||
, GHC.Platform.pc_MUT_ARR_PTRS_CARD_BITS = 0
|
||||
, GHC.Platform.pc_OFFSET_bdescr_blocks = 0
|
||||
, GHC.Platform.pc_OFFSET_bdescr_flags = 0
|
||||
, GHC.Platform.pc_OFFSET_bdescr_free = 0
|
||||
, GHC.Platform.pc_OFFSET_bdescr_start = 0
|
||||
, GHC.Platform.pc_OFFSET_Capability_r = 0
|
||||
, GHC.Platform.pc_OFFSET_CostCentreStack_mem_alloc = 0
|
||||
, GHC.Platform.pc_OFFSET_CostCentreStack_scc_count = 0
|
||||
, GHC.Platform.pc_OFFSET_StgArrBytes_bytes = 0
|
||||
, GHC.Platform.pc_OFFSET_stgEagerBlackholeInfo = 0
|
||||
, GHC.Platform.pc_OFFSET_StgEntCounter_allocd = 0
|
||||
, GHC.Platform.pc_OFFSET_StgEntCounter_allocs = 0
|
||||
, GHC.Platform.pc_OFFSET_StgEntCounter_entry_count = 0
|
||||
, GHC.Platform.pc_OFFSET_StgEntCounter_link = 0
|
||||
, GHC.Platform.pc_OFFSET_StgEntCounter_registeredp = 0
|
||||
, GHC.Platform.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
|
||||
, GHC.Platform.pc_OFFSET_StgFunInfoExtraRev_arity = 0
|
||||
, GHC.Platform.pc_OFFSET_stgGCEnter1 = 0
|
||||
, GHC.Platform.pc_OFFSET_stgGCFun = 0
|
||||
, GHC.Platform.pc_OFFSET_StgHeader_ccs = 0
|
||||
, GHC.Platform.pc_OFFSET_StgHeader_ldvw = 0
|
||||
, GHC.Platform.pc_OFFSET_StgMutArrPtrs_ptrs = 0
|
||||
, GHC.Platform.pc_OFFSET_StgMutArrPtrs_size = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rCCCS = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rCurrentNursery = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rCurrentTSO = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rD1 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rD2 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rD3 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rD4 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rD5 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rD6 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rF1 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rF2 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rF3 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rF4 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rF5 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rF6 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rHp = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rHpAlloc = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rHpLim = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rL1 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR1 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR10 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR2 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR3 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR4 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR5 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR6 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR7 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR8 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rR9 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rSp = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rSpLim = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM1 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM2 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM3 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM4 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM5 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rXMM6 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM1 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM2 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM3 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM4 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM5 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rYMM6 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM1 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM2 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM3 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM4 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM5 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgRegTable_rZMM6 = 0
|
||||
, GHC.Platform.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
|
||||
, GHC.Platform.pc_OFFSET_StgStack_sp = 0
|
||||
, GHC.Platform.pc_OFFSET_StgStack_stack = 0
|
||||
, GHC.Platform.pc_OFFSET_StgTSO_alloc_limit = 0
|
||||
, GHC.Platform.pc_OFFSET_StgTSO_cccs = 0
|
||||
, GHC.Platform.pc_OFFSET_StgTSO_stackobj = 0
|
||||
, GHC.Platform.pc_OFFSET_StgUpdateFrame_updatee = 0
|
||||
, GHC.Platform.pc_PROF_HDR_SIZE = 0
|
||||
, GHC.Platform.pc_REP_CostCentreStack_mem_alloc = 0
|
||||
, GHC.Platform.pc_REP_CostCentreStack_scc_count = 0
|
||||
, GHC.Platform.pc_REP_StgEntCounter_allocd = 0
|
||||
, GHC.Platform.pc_REP_StgEntCounter_allocs = 0
|
||||
, GHC.Platform.pc_REP_StgFunInfoExtraFwd_arity = 0
|
||||
, GHC.Platform.pc_REP_StgFunInfoExtraRev_arity = 0
|
||||
, GHC.Platform.pc_RESERVED_C_STACK_BYTES = 0
|
||||
, GHC.Platform.pc_RESERVED_STACK_WORDS = 0
|
||||
, GHC.Platform.pc_SIZEOF_CostCentreStack = 0
|
||||
, GHC.Platform.pc_SIZEOF_StgArrBytes_NoHdr = 0
|
||||
, GHC.Platform.pc_SIZEOF_StgFunInfoExtraRev = 0
|
||||
, GHC.Platform.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
|
||||
, GHC.Platform.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
|
||||
, GHC.Platform.pc_SIZEOF_StgSMPThunkHeader = 0
|
||||
, GHC.Platform.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
|
||||
, GHC.Platform.pc_STD_HDR_SIZE = 0
|
||||
, GHC.Platform.pc_TAG_BITS = 0
|
||||
, GHC.Platform.pc_TICKY_BIN_COUNT = 0
|
||||
, GHC.Platform.pc_WORD_SIZE = 0
|
||||
}
|
||||
|
||||
initialPlatformMini :: GHC.Settings.PlatformMini
|
||||
initialPlatformMini = GHC.Settings.PlatformMini
|
||||
{ GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64
|
||||
, GHC.Settings.platformMini_os = GHC.Platform.OSLinux
|
||||
initialPlatformArchOS :: GHC.Platform.ArchOS
|
||||
initialPlatformArchOS = GHC.Platform.ArchOS
|
||||
{ GHC.Platform.archOS_arch = GHC.Platform.ArchX86_64
|
||||
, GHC.Platform.archOS_OS = GHC.Platform.OSLinux
|
||||
}
|
||||
|
||||
initialTargetPlatform :: GHC.Settings.Platform
|
||||
|
@ -265,7 +261,8 @@ initialTargetPlatform = GHC.Settings.Platform
|
|||
, GHC.Settings.platformHasSubsectionsViaSymbols = False
|
||||
, GHC.Settings.platformIsCrossCompiling = False
|
||||
, GHC.Settings.platformLeadingUnderscore = False
|
||||
, GHC.Settings.platformMini = initialPlatformMini
|
||||
, GHC.Settings.platformArchOS = initialPlatformArchOS
|
||||
, GHC.Settings.platform_constants = Just initialPlatformConstants
|
||||
, GHC.Settings.platformTablesNextToCode = False
|
||||
, GHC.Settings.platformUnregisterised = False
|
||||
, GHC.Settings.platformWordSize = GHC.Platform.PW8
|
||||
|
|
|
@ -18,33 +18,34 @@ import Data.Generics.Uniplate.Direct as Uniplate
|
|||
import qualified Data.Kind as Kind
|
||||
import qualified Data.Strict.Maybe as Strict
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
|
||||
import GHC (AnnKeywordId, GenLocated, Located, LocatedAn, SrcSpan)
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import Language.Haskell.GHC.ExactPrint (AnnKey)
|
||||
-- import Language.Haskell.GHC.ExactPrint (AnnKey)
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
|
||||
import Language.Haskell.GHC.ExactPrint.Types (Anns)
|
||||
-- import Language.Haskell.GHC.ExactPrint.Types (Anns)
|
||||
import qualified Safe
|
||||
|
||||
import Language.Haskell.Brittany.Internal.EPCompat
|
||||
|
||||
data PerItemConfig = PerItemConfig
|
||||
{ _icd_perBinding :: Map String (CConfig Maybe)
|
||||
, _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)
|
||||
, _icd_perKey :: Map AnnKey (CConfig Maybe)
|
||||
}
|
||||
deriving Data.Data.Data
|
||||
|
||||
type PPM = MultiRWSS.MultiRWS
|
||||
'[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
|
||||
'[Map AnnKey Anns, PerItemConfig, Config, Anns]
|
||||
'[Text.Builder.Builder, [BrittanyError], Seq String]
|
||||
'[]
|
||||
|
||||
type PPMLocal = MultiRWSS.MultiRWS
|
||||
'[Config, ExactPrint.Anns]
|
||||
'[Config, Anns]
|
||||
'[Text.Builder.Builder, [BrittanyError], Seq String]
|
||||
'[]
|
||||
|
||||
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
|
||||
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map AnnKey String)
|
||||
|
||||
data LayoutState = LayoutState
|
||||
{ _lstate_baseYs :: [Int]
|
||||
|
@ -131,7 +132,7 @@ instance Show LayoutState where
|
|||
-- -- when creating zero-indentation
|
||||
-- -- multi-line list literals.
|
||||
-- , _lsettings_importColumn :: Int
|
||||
-- , _lsettings_initialAnns :: ExactPrint.Anns
|
||||
-- , _lsettings_initialAnns :: Anns
|
||||
-- }
|
||||
|
||||
data BrittanyError
|
||||
|
@ -144,7 +145,7 @@ data BrittanyError
|
|||
-- output and second the corresponding, ill-formed input.
|
||||
| LayoutWarning String
|
||||
-- ^ some warning
|
||||
| forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast)
|
||||
| forall ast an. Data.Data.Data ast => ErrorUnknownNode String (LocatedAn an ast)
|
||||
-- ^ internal error: pretty-printing is not implemented for type of node
|
||||
-- in the syntax-tree
|
||||
| ErrorOutputCheck
|
||||
|
@ -218,9 +219,9 @@ type ToBriDocM = MultiRWSS.MultiRWS
|
|||
'[[BrittanyError], Seq String] -- writer
|
||||
'[NodeAllocIndex] -- state
|
||||
|
||||
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
|
||||
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
|
||||
type ToBriDocC sym c = Located sym -> ToBriDocM c
|
||||
type ToBriDoc an (sym :: Kind.Type -> Kind.Type) = LocatedAn an (sym GhcPs) -> ToBriDocM BriDocNumbered
|
||||
type ToBriDoc' an sym = LocatedAn an sym -> ToBriDocM BriDocNumbered
|
||||
type ToBriDocC an sym c = LocatedAn an sym -> ToBriDocM c
|
||||
|
||||
data DocMultiLine
|
||||
= MultiLineNo
|
||||
|
|
|
@ -17,9 +17,10 @@ import qualified Data.Sequence as Seq
|
|||
import DataTreePrint
|
||||
import qualified GHC.Data.FastString as GHC
|
||||
import qualified GHC.Driver.Session as GHC
|
||||
import qualified GHC.Hs.Extension as HsExtension
|
||||
import qualified GHC.Driver.Ppr as GHC
|
||||
import qualified GHC.OldList as List
|
||||
import GHC.Types.Name.Occurrence as OccName (occNameString)
|
||||
import qualified GHC.Parser.Annotation as GHC
|
||||
import qualified GHC.Types.SrcLoc as GHC
|
||||
import qualified GHC.Utils.Outputable as GHC
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
|
@ -28,8 +29,10 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
|
|||
import Language.Haskell.Brittany.Internal.Types
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
|
||||
import qualified Language.Haskell.Syntax.Extension as HsExtension
|
||||
import qualified Text.PrettyPrint as PP
|
||||
|
||||
import Language.Haskell.Brittany.Internal.EPCompat
|
||||
|
||||
|
||||
parDoc :: String -> PP.Doc
|
||||
|
@ -40,10 +43,10 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords
|
|||
|
||||
|
||||
showSDoc_ :: GHC.SDoc -> String
|
||||
showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
|
||||
showSDoc_ = GHC.showSDoc undefined -- GHC.unsafeGlobalDynFlags
|
||||
|
||||
showOutputable :: (GHC.Outputable a) => a -> String
|
||||
showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
|
||||
showOutputable = GHC.showPpr undefined -- GHC.unsafeGlobalDynFlags
|
||||
|
||||
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
|
||||
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
|
||||
|
@ -72,8 +75,8 @@ instance Show ShowIsId where
|
|||
data A x = A ShowIsId x
|
||||
deriving Data
|
||||
|
||||
customLayouterF :: ExactPrint.Types.Anns -> LayouterF
|
||||
customLayouterF anns layoutF =
|
||||
customLayouterF :: LayouterF
|
||||
customLayouterF layoutF =
|
||||
DataToLayouter
|
||||
$ f
|
||||
`extQ` showIsId
|
||||
|
@ -104,12 +107,12 @@ customLayouterF anns layoutF =
|
|||
$ "{"
|
||||
++ showOutputable ss
|
||||
++ "}"
|
||||
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
|
||||
located :: (Data b, Data ann) => GHC.GenLocated ann b -> NodeLayouter
|
||||
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
|
||||
where
|
||||
annStr = case cast ss of
|
||||
Just (s :: GHC.SrcSpan) ->
|
||||
ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
|
||||
Just (s :: GHC.SrcLoc) ->
|
||||
ShowIsId $ "printing anns on 9.2.1: not implemented" ++ undefined
|
||||
Nothing -> ShowIsId "nnnnnnnn"
|
||||
|
||||
customLayouterNoAnnsF :: LayouterF
|
||||
|
@ -226,9 +229,9 @@ briDocToDoc = astToDoc . removeAnnotations
|
|||
briDocToDocWithAnns :: BriDoc -> PP.Doc
|
||||
briDocToDocWithAnns = astToDoc
|
||||
|
||||
annsDoc :: ExactPrint.Types.Anns -> PP.Doc
|
||||
annsDoc :: EPAnns -> PP.Doc
|
||||
annsDoc =
|
||||
printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
|
||||
printTreeWithCustom 100 customLayouterNoAnnsF
|
||||
|
||||
breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
|
||||
breakEither _ [] = ([], [])
|
||||
|
|
Loading…
Reference in New Issue