pull/366/merge
mrgutkun 2022-11-11 15:48:26 -07:00 committed by GitHub
commit dfe66157a3
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
21 changed files with 852 additions and 771 deletions

View File

@ -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

View File

@ -57,7 +57,7 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified 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)

View File

@ -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) ->

View File

@ -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)

View File

@ -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 ()

View File

@ -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

View File

@ -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]

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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

View File

@ -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)

View File

@ -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 "

View File

@ -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)

View File

@ -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]

View File

@ -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

View File

@ -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))

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 _ [] = ([], [])