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

Merge a3ae082f29 into e03ab8425b

pull/366/merge
mrgutkun 2022-11-11 15:48:26 -07:00 committed by GitHub
parent e03ab8425b a3ae082f29
commit dfe66157a3
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
21 changed files with 852 additions and 771 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
brittany.cabal
View File

@ -39,9 +39,9 @@ flag pedantic
common library common library
build-depends: build-depends:
, aeson ^>= 2.0.1 , aeson ^>= 2.0.1
, base ^>= 4.15.0 , base ^>= 4.16.0
, butcher ^>= 1.3.3 , butcher ^>= 1.3.3
, bytestring ^>= 0.10.12 , bytestring ^>= 0.11
, cmdargs ^>= 0.10.21 , cmdargs ^>= 0.10.21
, containers ^>= 0.6.4 , containers ^>= 0.6.4
, czipwith ^>= 1.0.1 , czipwith ^>= 1.0.1
@ -50,10 +50,10 @@ common library
, directory ^>= 1.3.6 , directory ^>= 1.3.6
, extra ^>= 1.7.10 , extra ^>= 1.7.10
, filepath ^>= 1.4.2 , filepath ^>= 1.4.2
, ghc ^>= 9.0.1 , ghc ^>= 9.2.1
, ghc-boot ^>= 9.0.1 , ghc-boot ^>= 9.2.1
, ghc-boot-th ^>= 9.0.1 , ghc-boot-th ^>= 9.2.1
, ghc-exactprint ^>= 0.6.4 , ghc-exactprint ^>= 1.4
, monad-memo ^>= 0.5.3 , monad-memo ^>= 0.5.3
, mtl ^>= 2.2.2 , mtl ^>= 2.2.2
, multistate ^>= 0.8.0 , multistate ^>= 0.8.0

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

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

154
source/library/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -66,7 +66,7 @@ data ColBuildState = ColBuildState
type LayoutConstraints m type LayoutConstraints m
= ( MonadMultiReader Config m = ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m -- , MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m , MonadMultiWriter (Seq String) m
, MonadMultiState LayoutState m , MonadMultiState LayoutState m
@ -138,12 +138,12 @@ layoutBriDocM = \case
let let
tlines = Text.lines $ t <> Text.pack "\n" tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk -- anns <- mAsk
when shouldAddComment $ do when shouldAddComment $ do
layoutWriteAppend layoutWriteAppend
$ Text.pack $ Text.pack
$ "{-" $ "{-"
++ show (annKey, Map.lookup annKey anns) ++ show (annKey, Map.lookup annKey {-anns-} undefined :: Maybe String)
++ "-}" ++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do zip [1 ..] tlines `forM_` \(i, l) -> do
layoutWriteAppend $ l layoutWriteAppend $ l
@ -152,7 +152,7 @@ layoutBriDocM = \case
state <- mGet state <- mGet
let filterF k _ = not $ k `Set.member` subKeys let filterF k _ = not $ k `Set.member` subKeys
mSet $ state mSet $ state
{ _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state { _lstate_comments = undefined -- Map.filterWithKey filterF $ _lstate_comments state
} }
BDPlain t -> do BDPlain t -> do
layoutWriteAppend t layoutWriteAppend t
@ -162,12 +162,12 @@ layoutBriDocM = \case
let let
moveToExactLocationAction = case _lstate_curYOrAddNewline state of moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure () Left{} -> pure ()
Right{} -> moveToExactAnn annKey Right{} -> undefined -- moveToExactAnn annKey
mAnn <- do mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m let mAnn = {-ExactPrint.annPriorComments-} undefined <$> Map.lookup annKey m
mSet $ state mSet $ state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annPriorComments = [] }) (\ann -> ann {- ExactPrint.annPriorComments = [] -})
annKey annKey
m m
} }
@ -177,20 +177,20 @@ layoutBriDocM = \case
Just [] -> moveToExactLocationAction Just [] -> moveToExactLocationAction
Just priors -> do Just priors -> do
-- layoutResetSepSpace -- layoutResetSepSpace
priors -- priors
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do -- when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment -- let commentLines = Text.lines $ Text.pack $ comment
case comment of -- case comment of
('#' : _) -> -- ('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines) -- layoutMoveToCommentPos y (-999) (length commentLines)
-- ^ evil hack for CPP -- -- ^ evil hack for CPP
_ -> layoutMoveToCommentPos y x (length commentLines) -- _ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x -- -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y -- -- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines -- layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
moveToExactLocationAction moveToExactLocationAction
layoutBriDocM bd layoutBriDocM bd
BDAnnotationKW annKey keyword bd -> do BDAnnotationKW annKey keyword bd -> do
@ -198,22 +198,22 @@ layoutBriDocM = \case
mComments <- do mComments <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = {-ExactPrint.annsDP-} undefined <$> Map.lookup annKey m
let let
mToSpan = case mAnn of mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> -- Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
Just annR -- Just annR
_ -> Nothing _ -> Nothing
case mToSpan of case mToSpan of
Just anns -> do Just anns -> do
let let
(comments, rest) = flip spanMaybe anns $ \case (comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) -- (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing _ -> Nothing
mSet $ state mSet $ state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annsDP = rest }) (\ann -> ann {- ExactPrint.annsDP = rest -})
annKey annKey
m m
} }
@ -221,21 +221,22 @@ layoutBriDocM = \case
_ -> return Nothing _ -> return Nothing
case mComments of case mComments of
Nothing -> pure () Nothing -> pure ()
Just comments -> do Just comments -> undefined
comments -- do
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> -- comments
when (comment /= "(" && comment /= ")") $ do -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
let commentLines = Text.lines $ Text.pack $ comment -- when (comment /= "(" && comment /= ")") $ do
-- evil hack for CPP: -- let commentLines = Text.lines $ Text.pack $ comment
case comment of -- -- evil hack for CPP:
('#' : _) -> -- case comment of
layoutMoveToCommentPos y (-999) (length commentLines) -- ('#' : _) ->
_ -> layoutMoveToCommentPos y x (length commentLines) -- layoutMoveToCommentPos y (-999) (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x -- _ -> layoutMoveToCommentPos y x (length commentLines)
-- replicateM_ fixedX layoutWriteNewline -- -- fixedX <- fixMoveToLineByIsNewline x
-- layoutMoveToIndentCol y -- -- replicateM_ fixedX layoutWriteNewline
layoutWriteAppendMultiline commentLines -- -- layoutMoveToIndentCol y
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- layoutWriteAppendMultiline commentLines
-- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do BDAnnotationRest annKey bd -> do
layoutBriDocM bd layoutBriDocM bd
annMay <- do annMay <- do
@ -247,7 +248,7 @@ layoutBriDocM = \case
semiCount = length semiCount = length
[ () [ ()
| Just ann <- [annMay] | Just ann <- [annMay]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann -- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
] ]
shouldAddSemicolonNewlines <- shouldAddSemicolonNewlines <-
mAsk mAsk
@ -257,12 +258,12 @@ layoutBriDocM = \case
mModify $ \state -> state mModify $ \state -> state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
(\ann -> ann (\ann -> ann
{ ExactPrint.annFollowingComments = [] -- { ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = [] -- , ExactPrint.annPriorComments = []
, ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case -- , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False -- (ExactPrint.Types.AnnComment{}, _) -> False
_ -> True -- _ -> True
} -- }
) )
annKey annKey
(_lstate_comments state) (_lstate_comments state)
@ -271,41 +272,44 @@ layoutBriDocM = \case
Nothing -> do Nothing -> do
when shouldAddSemicolonNewlines $ do when shouldAddSemicolonNewlines $ do
[1 .. semiCount] `forM_` const layoutWriteNewline [1 .. semiCount] `forM_` const layoutWriteNewline
Just comments -> do Just comments -> undefined
comments -- do
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> -- comments
when (comment /= "(" && comment /= ")") $ do -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
let commentLines = Text.lines $ Text.pack comment -- when (comment /= "(" && comment /= ")") $ do
case comment of -- let commentLines = Text.lines $ Text.pack comment
('#' : _) -> layoutMoveToCommentPos y (-999) 1 -- case comment of
-- ^ evil hack for CPP -- ('#' : _) -> layoutMoveToCommentPos y (-999) 1
")" -> pure () -- -- ^ evil hack for CPP
-- ^ fixes the formatting of parens -- ")" -> pure ()
-- on the lhs of type alias defs -- -- ^ fixes the formatting of parens
_ -> layoutMoveToCommentPos y x (length commentLines) -- -- on the lhs of type alias defs
-- fixedX <- fixMoveToLineByIsNewline x -- _ -> layoutMoveToCommentPos y x (length commentLines)
-- replicateM_ fixedX layoutWriteNewline -- -- fixedX <- fixMoveToLineByIsNewline x
-- layoutMoveToIndentCol y -- -- replicateM_ fixedX layoutWriteNewline
layoutWriteAppendMultiline commentLines -- -- layoutMoveToIndentCol y
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- layoutWriteAppendMultiline commentLines
-- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
mDP <- do mDP <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m -- let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let let
relevant = relevant = undefined
[ dp -- [ dp
| Just ann <- [mAnn] -- | Just ann <- [mAnn]
, (ExactPrint.Types.G kw1, dp) <- ann -- -- , (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1
] -- , keyword == kw1
-- ]
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
case relevant of case relevant of
[] -> pure Nothing [] -> pure Nothing
(ExactPrint.Types.DP (y, x) : _) -> do _ -> pure undefined
mSet state { _lstate_commentNewlines = 0 } -- (ExactPrint.Types.DP (y, x) : _) -> do
pure $ Just (y - _lstate_commentNewlines state, x) -- mSet state { _lstate_commentNewlines = 0 }
-- pure $ Just (y - _lstate_commentNewlines state, x)
case mDP of case mDP of
Nothing -> pure () Nothing -> pure ()
Just (y, x) -> Just (y, x) ->

164
source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs
View File

@ -17,7 +17,7 @@ import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils 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 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 -- TODO: when refactoring is complete, the other version of this method
-- can probably be removed. -- can probably be removed.
moveToExactAnn -- moveToExactAnn
:: ( MonadMultiWriter Text.Builder.Builder m -- :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m -- , MonadMultiState LayoutState m
, MonadMultiReader (Map AnnKey Annotation) m -- -- , MonadMultiReader (Map AnnKey Annotation) m
) -- )
=> AnnKey -- => AnnKey
-> m () -- -> m ()
moveToExactAnn annKey = do -- moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey) -- traceLocal ("moveToExactAnn", annKey)
anns <- mAsk -- anns <- mAsk
case Map.lookup annKey anns of -- case Map.lookup annKey anns of
Nothing -> return () -- Nothing -> return ()
Just ann -> do -- Just ann -> do
-- curY <- mGet <&> _lstate_curY -- -- curY <- mGet <&> _lstate_curY
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann -- let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
-- mModify $ \state -> state { _lstate_addNewline = Just x } -- -- mModify $ \state -> state { _lstate_addNewline = Just x }
moveToY y -- moveToY y
moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state -> moveToY y = mModify $ \state ->
@ -379,77 +379,77 @@ moveToY y = mModify $ \state ->
-- then x-1 -- then x-1
-- else x -- else x
ppmMoveToExactLoc -- ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () -- :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do -- ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n" -- replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " " -- replicateM_ y $ mTell $ Text.Builder.fromString " "
-- TODO: update and use, or clean up. Currently dead code. -- TODO: update and use, or clean up. Currently dead code.
layoutWritePriorComments -- layoutWritePriorComments
:: ( Data.Data.Data ast -- :: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m -- , MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m -- , MonadMultiState LayoutState m
) -- )
=> Located ast -- => Located ast
-> m () -- -> m ()
layoutWritePriorComments ast = do -- layoutWritePriorComments ast = do
mAnn <- do -- mAnn <- do
state <- mGet -- state <- mGet
let key = ExactPrint.mkAnnKey ast -- let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state -- let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns -- let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state -- mSet $ state
{ _lstate_comments = Map.adjust -- { _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annPriorComments = [] }) -- (\ann -> ann { ExactPrint.annPriorComments = [] })
key -- key
anns -- anns
} -- }
return mAnn -- return mAnn
case mAnn of -- case mAnn of
Nothing -> return () -- Nothing -> return ()
Just priors -> do -- Just priors -> do
unless (null priors) $ layoutSetCommentCol -- unless (null priors) $ layoutSetCommentCol
priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> -- priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
do -- do
replicateM_ x layoutWriteNewline -- replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y -- layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
-- TODO: update and use, or clean up. Currently dead code. -- TODO: update and use, or clean up. Currently dead code.
-- this currently only extracs from the `annsDP` field of Annotations. -- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the -- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..". -- "..`annFollowingComments` are only added by AST transformations ..".
layoutWritePostComments -- layoutWritePostComments
:: ( Data.Data.Data ast -- :: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m -- , MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m -- , MonadMultiState LayoutState m
) -- )
=> Located ast -- => Located ast
-> m () -- -> m ()
layoutWritePostComments ast = do -- layoutWritePostComments ast = do
mAnn <- do -- mAnn <- do
state <- mGet -- state <- mGet
let key = ExactPrint.mkAnnKey ast -- let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state -- let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns -- let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state -- mSet $ state
{ _lstate_comments = Map.adjust -- { _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annFollowingComments = [] }) -- (\ann -> ann { ExactPrint.annFollowingComments = [] })
key -- key
anns -- anns
} -- }
return mAnn -- return mAnn
case mAnn of -- case mAnn of
Nothing -> return () -- Nothing -> return ()
Just posts -> do -- Just posts -> do
unless (null posts) $ layoutSetCommentCol -- unless (null posts) $ layoutSetCommentCol
posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> -- posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
do -- do
replicateM_ x layoutWriteNewline -- replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' ' -- layoutWriteAppend $ Text.pack $ replicate y ' '
mModify $ \s -> s { _lstate_addSepSpace = Nothing } -- mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment -- layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment layoutIndentRestorePostComment
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)

13
source/library/Language/Haskell/Brittany/Internal/EPCompat.hs Normal file
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 ()

167
source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
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 Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO import qualified System.IO
import Language.Haskell.Brittany.Internal.EPCompat
parseModule parseModule
:: [String] :: [String]
-> System.IO.FilePath -> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a)) -> (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 parseModule args fp dynCheck = do
str <- System.IO.readFile fp str <- System.IO.readFile fp
parseModuleFromString args fp dynCheck str parseModuleFromString args fp dynCheck str
@ -47,74 +47,75 @@ parseModuleFromString
-> System.IO.FilePath -> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a)) -> (GHC.DynFlags -> IO (Either String a))
-> String -> String
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -> IO (Either String (GHC.ParsedSource, a))
parseModuleFromString = ParseModule.parseModule parseModuleFromString = ParseModule.parseModule
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do commentAnnFixTransformGlob ast = undefined
let -- do
extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) -- let
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ -- extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
const Seq.empty -- extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
`SYB.ext1Q` (\l@(L span _) -> -- const Seq.empty
Seq.singleton (span, ExactPrint.mkAnnKey l) -- `SYB.ext1Q` (\l@(L span _) ->
) -- Seq.singleton (span, ExactPrint.mkAnnKey l)
let nodes = SYB.everything (<>) extract ast -- )
let -- let nodes = SYB.everything (<>) extract ast
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey -- let
annsMap = Map.fromListWith -- annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
(const id) -- annsMap = Map.fromListWith
[ (GHC.realSrcSpanEnd span, annKey) -- (const id)
| (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes -- [ (GHC.realSrcSpanEnd span, annKey)
] -- | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
nodes `forM_` (snd .> processComs annsMap) -- ]
where -- nodes `forM_` (snd .> processComs annsMap)
processComs annsMap annKey1 = do -- where
mAnn <- State.Class.gets fst <&> Map.lookup annKey1 -- processComs annsMap annKey1 = do
mAnn `forM_` \ann1 -> do -- mAnn <- State.Class.gets fst <&> Map.lookup annKey1
let -- mAnn `forM_` \ann1 -> do
priors = ExactPrint.annPriorComments ann1 -- let
follows = ExactPrint.annFollowingComments ann1 -- priors = ExactPrint.annPriorComments ann1
assocs = ExactPrint.annsDP ann1 -- follows = ExactPrint.annFollowingComments ann1
let -- assocs = ExactPrint.annsDP ann1
processCom -- let
:: (ExactPrint.Comment, ExactPrint.DeltaPos) -- processCom
-> ExactPrint.TransformT Identity Bool -- :: (ExactPrint.Comment, ExactPrint.DeltaPos)
processCom comPair@(com, _) = -- -> ExactPrint.TransformT Identity Bool
case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of -- processCom comPair@(com, _) =
comLoc -> case Map.lookupLE comLoc annsMap of -- case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of -- comLoc -> case Map.lookupLE comLoc annsMap of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> -- Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
move $> False -- (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
(x, y) | x == y -> move $> False -- move $> False
_ -> return True -- (x, y) | x == y -> move $> False
where -- _ -> return True
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 -- where
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 -- ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
loc1 = GHC.realSrcSpanStart annKeyLoc1 -- ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc2 = GHC.realSrcSpanStart annKeyLoc2 -- loc1 = GHC.realSrcSpanStart annKeyLoc1
move = ExactPrint.modifyAnnsT $ \anns -> -- loc2 = GHC.realSrcSpanStart annKeyLoc2
let -- move = ExactPrint.modifyAnnsT $ \anns ->
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns -- let
ann2' = ann2 -- ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
{ ExactPrint.annFollowingComments = -- ann2' = ann2
ExactPrint.annFollowingComments ann2 ++ [comPair] -- { ExactPrint.annFollowingComments =
} -- ExactPrint.annFollowingComments ann2 ++ [comPair]
in Map.insert annKey2 ann2' anns -- }
_ -> return True -- retain comment at current node. -- in Map.insert annKey2 ann2' anns
priors' <- filterM processCom priors -- _ -> return True -- retain comment at current node.
follows' <- filterM processCom follows -- priors' <- filterM processCom priors
assocs' <- flip filterM assocs $ \case -- follows' <- filterM processCom follows
(ExactPrint.AnnComment com, dp) -> processCom (com, dp) -- assocs' <- flip filterM assocs $ \case
_ -> return True -- (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
let -- _ -> return True
ann1' = ann1 -- let
{ ExactPrint.annPriorComments = priors' -- ann1' = ann1
, ExactPrint.annFollowingComments = follows' -- { ExactPrint.annPriorComments = priors'
, ExactPrint.annsDP = assocs' -- , ExactPrint.annFollowingComments = follows'
} -- , ExactPrint.annsDP = assocs'
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns -- }
-- ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
-- TODO: this is unused by now, but it contains one detail that -- TODO: this is unused by now, but it contains one detail that
@ -181,27 +182,29 @@ commentAnnFixTransformGlob ast = do
-- ExactPrint.modifyAnnsT moveComments -- ExactPrint.modifyAnnsT moveComments
-- | split a set of annotations in a module into a map from top-level module -- | split a set of annotations in a module into a map from top-level module
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have. -- implementation would have.
extractToplevelAnns extractToplevelAnns
:: Located HsModule :: Located HsModule
-> ExactPrint.Anns -> Anns
-> Map ExactPrint.AnnKey ExactPrint.Anns -> Map AnnKey Anns
extractToplevelAnns lmod anns = output extractToplevelAnns lmod anns = output
where where
(L _ (HsModule _ _ _ _ ldecls _ _)) = lmod (L _ (HsModule _ _ _ _ _ ldecls _ _)) = lmod
declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey declMap1 :: Map AnnKey AnnKey
declMap1 = Map.unions $ ldecls <&> \ldecl -> declMap1 = Map.unions $ ldecls <&> \ldecl ->
Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) Map.fromSet (const ({-ExactPrint.mkAnnKey-} undefined ldecl)) (foldedAnnKeys ldecl)
declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey declMap2 :: Map AnnKey AnnKey
declMap2 = declMap2 =
Map.fromList Map.fromList
$ [ (captured, declMap1 Map.! k) $ [
| (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns -- (captured, declMap1 Map.! k)
-- | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
] ]
declMap = declMap1 `Map.union` declMap2 declMap = declMap1 `Map.union` declMap2
modKey = ExactPrint.mkAnnKey lmod modKey = {-ExactPrint.mkAnnKey-} undefined lmod
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
@ -212,13 +215,13 @@ groupMap f = Map.foldlWithKey'
insert k a Nothing = Just (Map.singleton k a) insert k a Nothing = Just (Map.singleton k a)
insert k a (Just m) = Just (Map.insert k a m) insert k a (Just m) = Just (Map.insert k a m)
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys :: Data.Data.Data ast => ast -> Set AnnKey
foldedAnnKeys ast = SYB.everything foldedAnnKeys ast = SYB.everything
Set.union Set.union
(\x -> maybe (\x -> maybe
Set.empty Set.empty
Set.singleton Set.singleton
[ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x [ SYB.gmapQi 1 ({-ExactPrint.mkAnnKey-} undefined . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x) | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
] ]
@ -233,8 +236,8 @@ foldedAnnKeys ast = SYB.everything
withTransformedAnns withTransformedAnns
:: Data ast :: Data ast
=> ast => ast
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config , Anns] w s a
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config , Anns] w s a
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
readers@(conf :+: anns :+: HNil) -> do readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS -- TODO: implement `local` for MultiReader/MultiRWS
@ -245,9 +248,9 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
where where
f anns = f anns =
let let
((), (annsBalanced, _), _) = ((), _, _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) ExactPrint.runTransform (commentAnnFixTransformGlob ast)
in annsBalanced in anns
warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat :: GHC.Warn -> String

249
source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
View File

@ -17,7 +17,7 @@ import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import DataTreePrint import DataTreePrint
import GHC (GenLocated(L), Located, moduleName, moduleNameString) import GHC (GenLocated(L), Located, LocatedAn, moduleName, moduleNameString)
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..)) import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.Name (getOccString) 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.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint 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.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint 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 qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Language.Haskell.Brittany.Internal.EPCompat
processDefault processDefault
:: ( ExactPrint.Annotate.Annotate ast :: (
-- ExactPrint.Annotate.Annotate ast
ExactPrint.ExactPrint ast
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiReader ExactPrint.Types.Anns m -- , MonadMultiReader ExactPrint.Types.Anns m
) )
=> Located ast => Located ast
-> m () -> m ()
processDefault x = do processDefault x = do
anns <- mAsk -- anns <- mAsk
let str = ExactPrint.exactPrint x anns let str = ExactPrint.exactPrint x {-anns-}
-- this hack is here so our print-empty-module trick does not add -- 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 -- a newline at the start if there actually is no module header / imports
-- / anything. -- / anything.
@ -63,16 +65,18 @@ processDefault x = do
-- not handled by brittany yet). Useful when starting implementing new -- not handled by brittany yet). Useful when starting implementing new
-- syntactic constructs when children are not handled yet. -- syntactic constructs when children are not handled yet.
briDocByExact briDocByExact
:: (ExactPrint.Annotate.Annotate ast) ::
=> Located ast -- (ExactPrint.Annotate.Annotate ast)
(Data ast, Data an)
=> LocatedAn an ast
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExact ast = do briDocByExact ast = do
anns <- mAsk -- anns <- mAsk
traceIfDumpConf traceIfDumpConf
"ast" "ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
docExt ast anns True docExt ast {-anns-} True
-- | Use ExactPrint's output for this node. -- | Use ExactPrint's output for this node.
-- Consider that for multi-line input, the indentation of the code produced -- 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 -- of its surroundings as layouted by brittany. But there are safe uses of
-- this, e.g. for any top-level declarations. -- this, e.g. for any top-level declarations.
briDocByExactNoComment briDocByExactNoComment
:: (ExactPrint.Annotate.Annotate ast) ::
=> Located ast -- (ExactPrint.Annotate.Annotate ast)
(Data ast, Data an)
=> LocatedAn an ast
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do briDocByExactNoComment ast = do
anns <- mAsk -- anns <- mAsk
traceIfDumpConf traceIfDumpConf
"ast" "ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
docExt ast anns False docExt ast {-anns-} False
-- | Use ExactPrint's output for this node, presuming that this output does -- | Use ExactPrint's output for this node, presuming that this output does
-- not contain any newlines. If this property is not met, the semantics -- not contain any newlines. If this property is not met, the semantics
-- depend on the @econf_AllowRiskyExactPrintUse@ config flag. -- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
briDocByExactInlineOnly briDocByExactInlineOnly
:: (ExactPrint.Annotate.Annotate ast) ::
-- (ExactPrint.Annotate.Annotate ast)
(Data ast, ExactPrint.ExactPrint (LocatedAn an ast), Data an)
=> String => String
-> Located ast -> LocatedAn an ast
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do briDocByExactInlineOnly infoStr ast = do
anns <- mAsk -- anns <- mAsk
traceIfDumpConf traceIfDumpConf
"ast" "ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns let exactPrinted = Text.pack $ ExactPrint.exactPrint ast {-anns-}
fallbackMode <- fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let let
exactPrintNode t = allocateNode $ BDFExternal exactPrintNode t = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey ast) -- ({-ExactPrint.Types.mkAnnKey-} undefined ast)
(foldedAnnKeys ast) undefined
-- (foldedAnnKeys ast)
undefined
False False
t t
let let
@ -138,38 +148,48 @@ lrdrNameToText :: GenLocated l RdrName -> Text
lrdrNameToText (L _ n) = rdrNameToText n lrdrNameToText (L _ n) = rdrNameToText n
lrdrNameToTextAnnGen lrdrNameToTextAnnGen
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) :: (MonadMultiReader Config m
-- , MonadMultiReader (Map AnnKey Annotation) m
)
=> (Text -> Text) => (Text -> Text)
-> Located RdrName -> LocatedAn an RdrName
-> m Text -> m Text
lrdrNameToTextAnnGen f ast@(L _ n) = do lrdrNameToTextAnnGen f ast@(L _ n) = do
anns <- mAsk -- anns <- mAsk
let t = f $ rdrNameToText n let t = f $ rdrNameToText n
let let
hasUni x (ExactPrint.Types.G y, _) = x == y -- hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here. -- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the -- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe -- output. in such cases, resorting to byExact is probably the safe
-- choice. -- 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 Nothing -> t
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} _ -> case n of
Exact{} | t == Text.pack "()" -> t Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t _ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t _ | otherwise -> t
where
aks :: [a]
aks = undefined
lrdrNameToTextAnn lrdrNameToTextAnn
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) :: (MonadMultiReader Config m
=> Located RdrName -- , MonadMultiReader (Map AnnKey Annotation) m
)
=> LocatedAn an RdrName
-> m Text -> m Text
lrdrNameToTextAnn = lrdrNameToTextAnnGen id lrdrNameToTextAnn = lrdrNameToTextAnnGen id
lrdrNameToTextAnnTypeEqualityIsSpecial lrdrNameToTextAnnTypeEqualityIsSpecial
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) :: (MonadMultiReader Config m
=> Located RdrName -- , MonadMultiReader (Map AnnKey Annotation) m
)
=> LocatedAn an RdrName
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let let
@ -186,10 +206,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
:: ( Data ast :: ( Data ast
, MonadMultiReader Config m , MonadMultiReader Config m
, MonadMultiReader (Map AnnKey Annotation) m -- , MonadMultiReader (Map AnnKey Annotation) m
) )
=> Located ast => LocatedAn an ast
-> Located RdrName -> LocatedAn an RdrName
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
@ -205,60 +225,62 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
extractAllComments extractAllComments
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] :: Annotation -> [(Comment, DeltaPos)]
extractAllComments ann = extractAllComments ann =
ExactPrint.annPriorComments ann ++ extractRestComments ann undefined
-- ExactPrint.annPriorComments ann ++ extractRestComments ann
extractRestComments extractRestComments
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] :: Annotation -> [(Comment, DeltaPos)]
extractRestComments ann = extractRestComments ann =
ExactPrint.annFollowingComments ann undefined
++ (ExactPrint.annsDP ann >>= \case -- ExactPrint.annFollowingComments ann
(ExactPrint.AnnComment com, dp) -> [(com, dp)] -- ++ (ExactPrint.annsDP ann >>= \case
_ -> [] -- (ExactPrint.AnnComment com, dp) -> [(com, dp)]
) -- _ -> []
-- )
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -- filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) -- filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-- | True if there are any comments that are -- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND -- a) connected to any node below (in AST sense) the given node AND
-- b) after (in source code order) the node. -- 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 _) = 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 <$> astConnectedComments ast
hasCommentsBetween hasCommentsBetween
:: Data ast :: Data ast
=> GHC.Located ast => GHC.LocatedAn an ast
-> AnnKeywordId -> AnnKeywordId
-> AnnKeywordId -> AnnKeywordId
-> ToBriDocM Bool -> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast mAnn <- {-astAnn-} undefined ast
let let
go1 [] = False 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 go1 (_ : rest) = go1 rest
go2 [] = False go2 [] = False
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True -- go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False -- go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 (_ : rest) = go2 rest go2 (_ : rest) = go2 rest
case mAnn of case mAnn of
Nothing -> pure False 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 -- | True if there are any comments that are connected to any node below (in AST
-- sense) the given node -- 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 hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST -- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node -- sense) the given node
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyRegularCommentsConnected :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast = hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast any {-isRegularComment-} undefined <$> astConnectedComments ast
-- | Regular comments are comments that are actually "source code comments", -- | Regular comments are comments that are actually "source code comments",
-- i.e. things that start with "--" or "{-". In contrast to comment-annotations -- 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 -- 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 -- only care about "regular" comments. We simply did not need the distinction
-- because "irregular" comments are not that common outside of type/data decls. -- because "irregular" comments are not that common outside of type/data decls.
isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool -- isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst -- isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
astConnectedComments astConnectedComments
:: Data ast :: Data ast
=> GHC.Located ast => GHC.LocatedAn an ast
-> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] -> ToBriDocM [(Comment, DeltaPos)]
astConnectedComments ast = do astConnectedComments ast = do
anns <- filterAnns ast <$> mAsk undefined
pure $ extractAllComments =<< Map.elems anns -- anns <- filterAnns ast <$> mAsk
-- pure $ extractAllComments =<< Map.elems anns
hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsPrior ast = astAnn ast <&> \case hasAnyCommentsPrior ast = {-astAnn-} undefined ast <&> \case
Nothing -> False 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 :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
hasAnyRegularCommentsRest ast = astAnn ast <&> \case hasAnyRegularCommentsRest ast = {-astAnn-} undefined ast <&> \case
Nothing -> False Nothing -> False
Just ann -> any isRegularComment (extractRestComments ann) Just ann -> undefined -- any isRegularComment (extractRestComments ann)
hasAnnKeywordComment hasAnnKeywordComment
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool :: Data ast => GHC.LocatedAn an ast -> AnnKeywordId -> ToBriDocM Bool
hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case hasAnnKeywordComment ast annKeyword = {-astAnn-} undefined ast <&> \case
Nothing -> False Nothing -> False
Just ann -> any hasK (extractAllComments ann) Just ann -> any hasK ({-extractAllComments-} thing ann)
where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst where
hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
thing ann = [undefined]
hasAnnKeyword hasAnnKeyword
:: (Data a, MonadMultiReader (Map AnnKey Annotation) m) :: (Data a
=> Located a -- , MonadMultiReader (Map AnnKey Annotation) m
, Functor m
)
=> LocatedAn an a
-> AnnKeywordId -> AnnKeywordId
-> m Bool -> m Bool
hasAnnKeyword ast annKeyword = astAnn ast <&> \case hasAnnKeyword ast annKeyword = {-astAnn-} astAnn' ast <&> \case
Nothing -> False Nothing -> False
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} undefined -> any hasK aks
where where
hasK (ExactPrint.Types.G x, _) = x == annKeyword -- hasK (ExactPrint.Types.G x, _) = x == annKeyword
hasK _ = False hasK _ = False
aks = [undefined]
-- astAnn' :: Functor f => Located a -> f (Maybe b)
astAnn' = undefined
astAnn -- astAnn
:: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) -- :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
=> GHC.Located ast -- => GHC.Located ast
-> m (Maybe Annotation) -- -> m (Maybe Annotation)
astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk -- astAnn ast = {-Map.lookup ({-ExactPrint.Types.mkAnnKey-} undefined ast)-} undefined <$> mAsk
-- new BriDoc stuff -- new BriDoc stuff
@ -338,7 +370,7 @@ allocNodeIndex = do
-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) -- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)
-- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered -- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered
-- docExt x anns shouldAddComment = allocateNode $ BDFExternal -- docExt x anns shouldAddComment = allocateNode $ BDFExternal
-- (ExactPrint.Types.mkAnnKey x) -- ({-ExactPrint.Types.mkAnnKey-} undefined x)
-- (foldedAnnKeys x) -- (foldedAnnKeys x)
-- shouldAddComment -- shouldAddComment
-- (Text.pack $ ExactPrint.exactPrint x anns) -- (Text.pack $ ExactPrint.exactPrint x anns)
@ -393,7 +425,7 @@ allocNodeIndex = do
-- -> m BriDocNumbered -- -> m BriDocNumbered
-- docPostComment ast bdm = do -- docPostComment ast bdm = do
-- bd <- bdm -- 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) -- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
-- => Located ast -- => Located ast
@ -405,9 +437,9 @@ allocNodeIndex = do
-- i2 <- allocNodeIndex -- i2 <- allocNodeIndex
-- return -- return
-- $ (,) i1 -- $ (,) i1
-- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) -- $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast)
-- $ (,) i2 -- $ (,) i2
-- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) -- $ BDFAnnotationPost ({-ExactPrint.Types.mkAnnKey-} undefined ast)
-- $ bd -- $ bd
-- --
-- docPar :: MonadMultiState NodeAllocIndex m -- docPar :: MonadMultiState NodeAllocIndex m
@ -438,16 +470,19 @@ docLitS :: String -> ToBriDocM BriDocNumbered
docLitS s = allocateNode $ BDFLit $ Text.pack s docLitS s = allocateNode $ BDFLit $ Text.pack s
docExt docExt
:: (ExactPrint.Annotate.Annotate ast) ::
=> Located ast -- (ExactPrint.Annotate.Annotate ast)
-> ExactPrint.Types.Anns LocatedAn an ast
-- -> ExactPrint.Types.Anns
-> Bool -> Bool
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docExt x anns shouldAddComment = allocateNode $ BDFExternal docExt x shouldAddComment = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey x) -- ({-ExactPrint.Types.mkAnnKey-} undefined x)
(foldedAnnKeys x) undefined
-- (foldedAnnKeys x)
undefined
shouldAddComment shouldAddComment
(Text.pack $ ExactPrint.exactPrint x anns) (Text.pack $ {-ExactPrint.exactPrint x anns-} undefined)
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docAlt l = allocateNode . BDFAlt =<< sequence l docAlt l = allocateNode . BDFAlt =<< sequence l
@ -580,34 +615,34 @@ docTick = docLit $ Text.pack "'"
docNodeAnnKW docNodeAnnKW
:: Data.Data.Data ast :: Data.Data.Data ast
=> Located ast => LocatedAn an ast
-> Maybe AnnKeywordId -> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNodeAnnKW ast kw bdm = docNodeAnnKW ast kw bdm =
docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm docAnnotationKW ({-{-ExactPrint.Types.mkAnnKey-} undefined-} undefined ast) kw bdm
docNodeMoveToKWDP docNodeMoveToKWDP
:: Data.Data.Data ast :: Data.Data.Data ast
=> Located ast => LocatedAn an ast
-> AnnKeywordId -> AnnKeywordId
-> Bool -> Bool
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = 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 class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast) docWrapNode :: ( Data.Data.Data ast)
=> Located ast => LocatedAn an ast
-> a -> a
-> a -> a
docWrapNodePrior :: ( Data.Data.Data ast) docWrapNodePrior :: ( Data.Data.Data ast)
=> Located ast => LocatedAn an ast
-> a -> a
-> a -> a
docWrapNodeRest :: ( Data.Data.Data ast) docWrapNodeRest :: ( Data.Data.Data ast)
=> Located ast => LocatedAn an ast
-> a -> a
-> a -> a
@ -618,18 +653,18 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
i2 <- allocNodeIndex i2 <- allocNodeIndex
return return
$ (,) i1 $ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast)
$ (,) i2 $ (,) i2
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ BDFAnnotationRest ({-ExactPrint.Types.mkAnnKey-} undefined ast)
$ bd $ bd
docWrapNodePrior ast bdm = do docWrapNodePrior ast bdm = do
bd <- bdm bd <- bdm
i1 <- allocNodeIndex i1 <- allocNodeIndex
return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd return $ (,) i1 $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd
docWrapNodeRest ast bdm = do docWrapNodeRest ast bdm = do
bd <- bdm bd <- bdm
i2 <- allocNodeIndex 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 instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
docWrapNode ast bdms = case bdms of docWrapNode ast bdms = case bdms of
@ -746,7 +781,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
unknownNodeError unknownNodeError
:: Data.Data.Data ast :: Data.Data.Data ast
=> String => String
-> GenLocated GHC.SrcSpan ast -> LocatedAn an ast
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
unknownNodeError infoStr ast = do unknownNodeError infoStr ast = do
mTell [ErrorUnknownNode infoStr ast] mTell [ErrorUnknownNode infoStr ast]

71
source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

@ -20,16 +20,17 @@ import Language.Haskell.Brittany.Internal.Types
layoutDataDecl layoutDataDecl
:: Located (TyClDecl GhcPs) :: Data.Data.Data an1
-> Located RdrName => LocatedAn an1 (TyClDecl GhcPs)
-> LocatedAn an2 RdrName
-> LHsQTyVars GhcPs -> LHsQTyVars GhcPs
-> HsDataDefn GhcPs -> HsDataDefn GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- newtype MyType a b = MyType .. -- newtype MyType a b = MyType ..
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> HsDataDefn _ext NewType _ctxt _ctype Nothing [cons] mDerivs ->
case cons of 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 -> docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
@ -54,9 +55,9 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData a b -- data MyData a b
-- (zero constructors) -- (zero constructors)
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> HsDataDefn _ext DataType mLhsContext _ctype Nothing [] mDerivs ->
docWrapNode ltycl $ do docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq createDerivingPar mDerivs $ docSeq
@ -68,11 +69,11 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData = MyData .. -- data MyData = MyData ..
-- 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 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 -> docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
@ -81,7 +82,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
Just x -> Just . pure <$> x Just x -> Just . pure <$> x
rhsContextDocMay <- case mRhsContext of rhsContextDocMay <- case mRhsContext of
Nothing -> pure Nothing Nothing -> pure Nothing
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt Just lctxt -> Just . pure <$> createContextDoc (Just lctxt)
rhsDoc <- return <$> createDetailsDoc consNameStr details rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <- consDoc <-
fmap pure fmap pure
@ -200,11 +201,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
_ -> briDocByExactNoComment ltycl _ -> briDocByExactNoComment ltycl
createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered createContextDoc :: Maybe (LHsContext GhcPs) -> ToBriDocM BriDocNumbered
createContextDoc [] = docEmpty createContextDoc Nothing = docEmpty
createContextDoc [t] = createContextDoc (Just (L _ lhsContext)) = case lhsContext of
docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] [] -> docEmpty
createContextDoc (t1 : tR) = do [t] -> docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
(t1 : tR) -> do
t1Doc <- docSharedWrapper layoutType t1 t1Doc <- docSharedWrapper layoutType t1
tRDocs <- tR `forM` docSharedWrapper layoutType tRDocs <- tR `forM` docSharedWrapper layoutType
docAlt docAlt
@ -246,20 +248,20 @@ createBndrDoc bs = do
createDerivingPar createDerivingPar
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
createDerivingPar derivs mainDoc = do createDerivingPar derivs mainDoc = do
case derivs of
(L _ []) -> mainDoc
(L _ types) ->
docPar mainDoc docPar mainDoc
$ docEnsureIndent BrIndentRegular $ docEnsureIndent BrIndentRegular
$ docLines $ docLines
$ docWrapNode derivs $ docWrapNode (noLocA derivs)
$ derivingClauseDoc $ derivingClauseDoc
<$> types <$> derivs
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
(L _ []) -> docSeq [] (L _ (DctSingle _ t)) -> derivingClauseDoc' [t]
(L _ ts) -> (L _ (DctMulti _ ts)) -> derivingClauseDoc' ts
where
derivingClauseDoc' [] = docSeq []
derivingClauseDoc' ts =
let let
tsLength = length ts tsLength = length ts
whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" 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 $ List.intersperse docCommaSep
$ ts $ ts
<&> \case <&> \case
HsIB _ t -> layoutType t _ -> undefined
-- HsIB _ t -> layoutType t
, whenMoreThan1Type ")" , whenMoreThan1Type ")"
, rhsStrategy , rhsStrategy
] ]
where strategyLeftRight
:: Located (DerivStrategy GhcPs)
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
strategyLeftRight = \case strategyLeftRight = \case
(L _ StockStrategy) -> (docLitS " stock", docEmpty) (L _ (StockStrategy _)) -> (docLitS " stock", docEmpty)
(L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) (L _ (AnyclassStrategy _)) -> (docLitS " anyclass", docEmpty)
(L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) (L _ (NewtypeStrategy _)) -> (docLitS " newtype", docEmpty)
lVia@(L _ (ViaStrategy viaTypes)) -> lVia@(L _ (ViaStrategy viaTypes)) ->
( docEmpty ( docEmpty
, case viaTypes of , case viaTypes of
HsIB _ext t -> XViaStrategyPs _epann (L _span (HsSig _sig _bndrs t)) ->
docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] docSeq [docWrapNode (reLocA lVia) $ docLitS " via", docSeparator, layoutType t]
) )
docDeriving :: ToBriDocM BriDocNumbered docDeriving :: ToBriDocM BriDocNumbered
docDeriving = docLitS "deriving" docDeriving = docLitS "deriving"
createDetailsDoc createDetailsDoc
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) :: Text -> HsConDeclH98Details GhcPs -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of createDetailsDoc consNameStr details = case details of
PrefixCon args -> do PrefixCon _ args -> do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
singleLine = docSeq singleLine = docSeq
@ -421,9 +426,9 @@ createForallDoc lhsTyVarBndrs =
createNamesAndTypeDoc createNamesAndTypeDoc
:: Data.Data.Data ast :: Data.Data.Data ast
=> Located ast => LocatedAn an1 ast
-> [GenLocated t (FieldOcc GhcPs)] -> [GenLocated t (FieldOcc GhcPs)]
-> Located (HsType GhcPs) -> LocatedAn AnnListItem (HsType GhcPs)
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t = createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq

85
source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -19,9 +19,9 @@ import GHC.Types.Basic
( Activation(..) ( Activation(..)
, InlinePragma(..) , InlinePragma(..)
, InlineSpec(..) , InlineSpec(..)
, LexicalFixity(..)
, RuleMatchInfo(..) , RuleMatchInfo(..)
) )
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc)
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils 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.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint 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 qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.EPCompat
layoutDecl :: ToBriDoc AnnListItem HsDecl
layoutDecl :: ToBriDoc HsDecl
layoutDecl d@(L loc decl) = case decl of layoutDecl d@(L loc decl) = case decl of
SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig)
ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
@ -57,9 +57,9 @@ layoutDecl d@(L loc decl) = case decl of
-- Sig -- Sig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
layoutSig :: ToBriDoc Sig layoutSig :: ToBriDoc AnnListItem Sig
layoutSig lsig@(L _loc sig) = case sig of 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) -> InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
@ -80,8 +80,8 @@ layoutSig lsig@(L _loc sig) = case sig of
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr <> nameStr
<> Text.pack " #-}" <> Text.pack " #-}"
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ ClassOpSig _ False names (L _ (HsSig _ _ typ)) -> layoutNamesAndType Nothing names typ
PatSynSig _ names (HsIB _ typ) -> PatSynSig _ names (L _ (HsSig _ _ typ)) ->
layoutNamesAndType (Just "pattern") names typ layoutNamesAndType (Just "pattern") names typ
_ -> briDocByExactNoComment lsig -- TODO _ -> briDocByExactNoComment lsig -- TODO
where where
@ -121,12 +121,12 @@ layoutSig lsig@(L _loc sig) = case sig of
specStringCompat specStringCompat
:: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
specStringCompat ast = \case specStringCompat ast = \case
NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" NoUserInlinePrag -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""
Inline -> pure "INLINE " Inline -> pure "INLINE "
Inlinable -> pure "INLINABLE " Inlinable -> pure "INLINABLE "
NoInline -> pure "NOINLINE " 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 layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BodyStmt _ body _ _ -> layoutExpr body BodyStmt _ body _ _ -> layoutExpr body
BindStmt _ lPat expr -> do BindStmt _ lPat expr -> do
@ -145,7 +145,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
layoutBind layoutBind
:: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) :: ToBriDocC an (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of layoutBind lbind@(L _ bind) = case bind of
FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do
idStr <- lrdrNameToTextAnn fId idStr <- lrdrNameToTextAnn fId
@ -160,7 +160,7 @@ layoutBind lbind@(L _ bind) = case bind of
patDocs <- colsWrapPat =<< layoutPat pat patDocs <- colsWrapPat =<< layoutPat pat
clauseDocs <- layoutGrhs `mapM` grhss clauseDocs <- layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds 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 "=" binderDoc <- docLit $ Text.pack "="
hasComments <- hasAnyCommentsBelow lbind hasComments <- hasAnyCommentsBelow lbind
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal fmap Right $ docWrapNode lbind $ layoutPatternBindFinal
@ -173,7 +173,7 @@ layoutBind lbind@(L _ bind) = case bind of
PatSynBind _ (PSB _ patID lpat rpat dir) -> do PatSynBind _ (PSB _ patID lpat rpat dir) -> do
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat
_ -> Right <$> unknownNodeError "" lbind _ -> Right <$> unknownNodeError "" lbind
layoutIPBind :: ToBriDoc IPBind layoutIPBind :: ToBriDoc an IPBind
layoutIPBind lipbind@(L _ bind) = case bind of layoutIPBind lipbind@(L _ bind) = case bind of
IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right"
IPBind _ (Left (L _ (HsIPName name))) expr -> do IPBind _ (Left (L _ (HsIPName name))) expr -> do
@ -193,13 +193,14 @@ layoutIPBind lipbind@(L _ bind) = case bind of
data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
| BagSig (LSig GhcPs) | BagSig (LSig GhcPs)
bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpanAnnA
bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l
layoutLocalBinds layoutLocalBinds
:: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) :: HsLocalBindsLR GhcPs GhcPs -> ToBriDocM (Maybe [BriDocNumbered])
layoutLocalBinds lbinds@(L _ binds) = case binds of -- :: ToBriDocC an (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
layoutLocalBinds binds = case binds of
-- HsValBinds (ValBindsIn lhsBindsLR []) -> -- HsValBinds (ValBindsIn lhsBindsLR []) ->
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
-- x@(HsValBinds (ValBindsIn{})) -> -- x@(HsValBinds (ValBindsIn{})) ->
@ -209,8 +210,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
unordered = unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ] [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ] ++ [ BagSig s | s <- sigs ]
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered ordered = List.sortOn (la2r . bindOrSigtoSrcSpan) unordered
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case docs <- docWrapNode (noLocA binds) $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s BagSig s -> return <$> layoutSig s
return $ Just $ docs return $ Just $ docs
@ -225,7 +226,7 @@ layoutGrhs
:: LGRHS GhcPs (LHsExpr GhcPs) :: LGRHS GhcPs (LHsExpr GhcPs)
-> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)
layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards guardDocs <- docWrapNode (reLocA lgrhs) $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body bodyDoc <- layoutExpr body
return (guardDocs, bodyDoc, body) return (guardDocs, bodyDoc, body)
@ -274,7 +275,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
$ (List.intersperse docSeparator $ docForceSingleline <$> ps) $ (List.intersperse docSeparator $ docForceSingleline <$> ps)
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds mWhereDocs <- layoutLocalBinds whereBinds
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let mWhereArg = mWhereDocs <&> (,) ({-mkAnnKey-} undefined lmatch)
let alignmentToken = if null pats then Nothing else funId let alignmentToken = if null pats then Nothing else funId
hasComments <- hasAnyCommentsBelow lmatch hasComments <- hasAnyCommentsBelow lmatch
layoutPatternBindFinal layoutPatternBindFinal
@ -307,7 +308,7 @@ layoutPatternBindFinal
-> BriDocNumbered -> BriDocNumbered
-> Maybe BriDocNumbered -> Maybe BriDocNumbered
-> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)]
-> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) -> Maybe (AnnKey, [BriDocNumbered])
-- ^ AnnKey for the node that contains the AnnWhere position annotation -- ^ AnnKey for the node that contains the AnnWhere position annotation
-> Bool -> Bool
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -610,8 +611,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
-- | Layout a pattern synonym binding -- | Layout a pattern synonym binding
layoutPatSynBind layoutPatSynBind
:: Located (IdP GhcPs) :: LIdP GhcPs
-> HsPatSynDetails (Located (IdP GhcPs)) -> HsPatSynDetails GhcPs
-> HsPatSynDir GhcPs -> HsPatSynDir GhcPs
-> LPat GhcPs -> LPat GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -663,10 +664,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do
-- | Helper method for the left hand side of a pattern synonym -- | Helper method for the left hand side of a pattern synonym
layoutLPatSyn layoutLPatSyn
:: Located (IdP GhcPs) :: LIdP GhcPs
-> HsPatSynDetails (Located (IdP GhcPs)) -> HsPatSynDetails GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutLPatSyn name (PrefixCon vars) = do layoutLPatSyn name (PrefixCon _ vars) = do
docName <- lrdrNameToTextAnn name docName <- lrdrNameToTextAnn name
names <- mapM lrdrNameToTextAnn vars names <- mapM lrdrNameToTextAnn vars
docSeq . fmap appSep $ docLit docName : (docLit <$> names) docSeq . fmap appSep $ docLit docName : (docLit <$> names)
@ -677,7 +678,7 @@ layoutLPatSyn name (InfixCon left right) = do
docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]
layoutLPatSyn name (RecCon recArgs) = do layoutLPatSyn name (RecCon recArgs) = do
docName <- lrdrNameToTextAnn name docName <- lrdrNameToTextAnn name
args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs args <- mapM (lrdrNameToTextAnn . rdrNameFieldOcc . recordPatSynField) recArgs
docSeq docSeq
. fmap docLit . fmap docLit
$ [docName, Text.pack " { "] $ [docName, Text.pack " { "]
@ -699,7 +700,7 @@ layoutPatSynWhere hs = case hs of
-- TyClDecl -- TyClDecl
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
layoutTyCl :: ToBriDoc TyClDecl layoutTyCl :: Data.Data.Data an => ToBriDoc an TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of layoutTyCl ltycl@(L _loc tycl) = case tycl of
SynDecl _ name vars fixity typ -> do SynDecl _ name vars fixity typ -> do
let let
@ -720,7 +721,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
layoutSynDecl layoutSynDecl
:: Bool :: Bool
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
-> Located (IdP GhcPs) -> LIdP GhcPs
-> [LHsTyVarBndr () GhcPs] -> [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs -> LHsType GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -756,7 +757,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
hasComments <- hasAnyCommentsConnected typ hasComments <- hasAnyCommentsConnected typ
layoutLhsAndType hasComments sharedLhs "=" typeDoc layoutLhsAndType hasComments sharedLhs "=" typeDoc
layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) layoutTyVarBndr :: Bool -> ToBriDoc an (HsTyVarBndr ())
layoutTyVarBndr needsSep lbndr@(L _ bndr) = do layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
docWrapNodePrior lbndr $ case bndr of docWrapNodePrior lbndr $ case bndr of
UserTyVar _ _ name -> do UserTyVar _ _ name -> do
@ -783,13 +784,13 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
layoutTyFamInstDecl layoutTyFamInstDecl
:: Data.Data.Data a :: Data.Data.Data a
=> Bool => Bool
-> Located a -> LocatedAn an a
-> TyFamInstDecl GhcPs -> TyFamInstDecl GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutTyFamInstDecl inClass outerNode tfid = do layoutTyFamInstDecl inClass outerNode tfid = do
let let
FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid FamEqn _ name bndrs pats _fixity typ = tfid_eqn tfid
-- bndrsMay isJust e.g. with -- bndrs isJust e.g. with
-- type instance forall a . MyType (Maybe a) = Either () a -- type instance forall a . MyType (Maybe a) = Either () a
innerNode = outerNode innerNode = outerNode
docWrapNodePrior outerNode $ do docWrapNodePrior outerNode $ do
@ -810,7 +811,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
docWrapNode innerNode docWrapNode innerNode
. docSeq . docSeq
$ [appSep instanceDoc] $ [appSep instanceDoc]
++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] ++ [ makeForallDoc foralls | HsOuterExplicit _ foralls <- [bndrs] ]
++ [ docParenL | needsParens ] ++ [ docParenL | needsParens ]
++ [appSep $ docWrapNode name $ docLit nameStr] ++ [appSep $ docWrapNode name $ docLit nameStr]
++ intersperse docSeparator (layoutHsTyPats pats) ++ intersperse docSeparator (layoutHsTyPats pats)
@ -842,7 +843,7 @@ layoutHsTyPats pats = pats <&> \case
-- Layout signatures and bindings using the corresponding layouters from the -- Layout signatures and bindings using the corresponding layouters from the
-- top-level. Layout the instance head, type family instances, and data family -- top-level. Layout the instance head, type family instances, and data family
-- instances using ExactPrint. -- instances using ExactPrint.
layoutClsInst :: ToBriDoc ClsInstDecl layoutClsInst :: Data.Data.Data an => ToBriDoc an ClsInstDecl
layoutClsInst lcid@(L _ cid) = docLines layoutClsInst lcid@(L _ cid) = docLines
[ layoutInstanceHead [ layoutInstanceHead
, docEnsureIndent BrIndentRegular , docEnsureIndent BrIndentRegular
@ -872,18 +873,18 @@ layoutClsInst lcid@(L _ cid) = docLines
-- | Like 'docLines', but sorts the lines based on location -- | Like 'docLines', but sorts the lines based on location
docSortedLines docSortedLines
:: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered :: [ToBriDocM (LocatedAn an BriDocNumbered)] -> ToBriDocM BriDocNumbered
docSortedLines l = docSortedLines l =
allocateNode allocateNode
. BDFLines . BDFLines
. fmap unLoc . fmap unLoc
. List.sortOn (ExactPrint.rs . getLoc) . List.sortOn (realSrcSpan . getLocA)
=<< sequence l =<< sequence l
layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig :: ToBriDocC AnnListItem (Sig GhcPs) (LocatedA BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig 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 _) = layoutAndLocateBind lbind@(L loc _) =
L loc <$> (joinBinds =<< layoutBind lbind) L loc <$> (joinBinds =<< layoutBind lbind)
@ -894,17 +895,17 @@ layoutClsInst lcid@(L _ cid) = docLines
Right n -> return n Right n -> return n
layoutAndLocateTyFamInsts layoutAndLocateTyFamInsts
:: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) :: ToBriDocC an (TyFamInstDecl GhcPs) (LocatedAn an BriDocNumbered)
layoutAndLocateTyFamInsts ltfid@(L loc tfid) = layoutAndLocateTyFamInsts ltfid@(L loc tfid) =
L loc <$> layoutTyFamInstDecl True ltfid tfid L loc <$> layoutTyFamInstDecl True ltfid tfid
layoutAndLocateDataFamInsts layoutAndLocateDataFamInsts
:: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) :: Data.Data.Data an => ToBriDocC an (DataFamInstDecl GhcPs) (LocatedAn an BriDocNumbered)
layoutAndLocateDataFamInsts ldfid@(L loc _) = layoutAndLocateDataFamInsts ldfid@(L loc _) =
L loc <$> layoutDataFamInstDecl ldfid L loc <$> layoutDataFamInstDecl ldfid
-- | Send to ExactPrint then remove unecessary whitespace -- | Send to ExactPrint then remove unecessary whitespace
layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl layoutDataFamInstDecl :: Data.Data.Data an => ToBriDoc an DataFamInstDecl
layoutDataFamInstDecl ldfid = layoutDataFamInstDecl ldfid =
fmap stripWhitespace <$> briDocByExactNoComment ldfid fmap stripWhitespace <$> briDocByExactNoComment ldfid

62
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

@ -8,12 +8,13 @@ import qualified Data.Data
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text 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 qualified GHC.Data.FastString as FastString
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Types.Basic import GHC.Types.Basic
import GHC.Types.Name import GHC.Types.Name
import GHC.Types.SourceText
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl 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 layoutExpr lexpr@(L _ expr) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let allowFreeIndent = indentPolicy == IndentPolicyFree let allowFreeIndent = indentPolicy == IndentPolicyFree
@ -38,7 +39,7 @@ layoutExpr lexpr@(L _ expr) = do
HsRecFld{} -> do HsRecFld{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsRecFld" lexpr briDocByExactInlineOnly "HsRecFld" lexpr
HsOverLabel _ext _reboundFromLabel name -> HsOverLabel _ext name ->
let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label
HsIPVar _ext (HsIPName name) -> HsIPVar _ext (HsIPName name) ->
let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label 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)]) _) HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _)
| pats <- m_pats match | pats <- m_pats match
, GRHSs _ [lgrhs] llocals <- m_grhss match , GRHSs _ [lgrhs] llocals <- m_grhss match
, L _ EmptyLocalBinds{} <- llocals , EmptyLocalBinds{} <- llocals
, L _ (GRHS _ [] body) <- lgrhs , L _ (GRHS _ [] body) <- lgrhs
-> do -> do
patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) ->
@ -86,7 +87,7 @@ layoutExpr lexpr@(L _ expr) = do
[ docLit $ Text.pack "\\" [ docLit $ Text.pack "\\"
, docWrapNode lmatch $ docForceSingleline funcPatternPartLine , docWrapNode lmatch $ docForceSingleline funcPatternPartLine
, appSep $ docLit $ Text.pack "->" , appSep $ docLit $ Text.pack "->"
, docWrapNode lgrhs $ docForceSingleline bodyDoc , docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc
] ]
-- double line -- double line
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
@ -97,13 +98,13 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack "->" , docLit $ Text.pack "->"
] ]
) )
(docWrapNode lgrhs $ docForceSingleline bodyDoc) (docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc)
-- wrapped par spacing -- wrapped par spacing
, docSetParSpacing $ docSeq , docSetParSpacing $ docSeq
[ docLit $ Text.pack "\\" [ docLit $ Text.pack "\\"
, docWrapNode lmatch $ docForceSingleline funcPatternPartLine , docWrapNode lmatch $ docForceSingleline funcPatternPartLine
, appSep $ docLit $ Text.pack "->" , appSep $ docLit $ Text.pack "->"
, docWrapNode lgrhs $ docForceParSpacing bodyDoc , docWrapNode (reLocA lgrhs) $ docForceParSpacing bodyDoc
] ]
-- conservative -- conservative
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
@ -114,7 +115,7 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack "->" , docLit $ Text.pack "->"
] ]
) )
(docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) (docWrapNode (reLocA lgrhs) $ docNonBottomSpacing bodyDoc)
] ]
HsLam{} -> unknownNodeError "HsLam too complex" lexpr HsLam{} -> unknownNodeError "HsLam too complex" lexpr
HsLamCase _ (MG _ (L _ []) _) -> do HsLamCase _ (MG _ (L _ []) _) -> do
@ -378,14 +379,14 @@ layoutExpr lexpr@(L _ expr) = do
ExplicitTuple _ args boxity -> do ExplicitTuple _ args boxity -> do
let let
argExprs = args <&> \arg -> case arg of argExprs = args <&> \arg -> case arg of
(L _ (Present _ e)) -> (arg, Just e) (Present _ e) -> (arg, Just e)
(L _ (Missing NoExtField)) -> (arg, Nothing) (Missing _) -> (arg, Nothing)
argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) ->
docWrapNode arg $ maybe docEmpty layoutExpr exprM docWrapNode (noLocA arg) $ maybe docEmpty layoutExpr exprM
hasComments <- hasComments <-
orM orM
(hasCommentsBetween lexpr AnnOpenP AnnCloseP (hasCommentsBetween lexpr AnnOpenP AnnCloseP
: map hasAnyCommentsBelow args : map (hasAnyCommentsBelow . noLocA) args
) )
let let
(openLit, closeLit) = case boxity of (openLit, closeLit) = case boxity of
@ -758,7 +759,7 @@ layoutExpr lexpr@(L _ expr) = do
_ -> do _ -> do
-- TODO -- TODO
unknownNodeError "HsDo{} unknown stmtCtx" lexpr unknownNodeError "HsDo{} unknown stmtCtx" lexpr
ExplicitList _ _ elems@(_ : _) -> do ExplicitList _ elems@(_ : _) -> do
elemDocs <- elems `forM` docSharedWrapper layoutExpr elemDocs <- elems `forM` docSharedWrapper layoutExpr
hasComments <- hasAnyCommentsBelow lexpr hasComments <- hasAnyCommentsBelow lexpr
case splitFirstLast elemDocs of case splitFirstLast elemDocs of
@ -800,12 +801,12 @@ layoutExpr lexpr@(L _ expr) = do
[docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]
end = docLit $ Text.pack "]" end = docLit $ Text.pack "]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
ExplicitList _ _ [] -> docLit $ Text.pack "[]" ExplicitList _ [] -> docLit $ Text.pack "[]"
RecordCon _ lname fields -> case fields of RecordCon _ lname fields -> case fields of
HsRecFields fs Nothing -> do HsRecFields fs Nothing -> do
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
rFs <- 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 let FieldOcc _ lnameF = fieldOcc
rFExpDoc <- if pun rFExpDoc <- if pun
then return Nothing then return Nothing
@ -818,7 +819,7 @@ layoutExpr lexpr@(L _ expr) = do
HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
fieldDocs <- 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 let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
@ -826,10 +827,10 @@ layoutExpr lexpr@(L _ expr) = do
return (fieldl, lrdrNameToText lnameF, fExpDoc) return (fieldl, lrdrNameToText lnameF, fExpDoc)
recordExpression True indentPolicy lexpr nameDoc fieldDocs recordExpression True indentPolicy lexpr nameDoc fieldDocs
_ -> unknownNodeError "RecordCon with puns" lexpr _ -> unknownNodeError "RecordCon with puns" lexpr
RecordUpd _ rExpr fields -> do RecordUpd _ rExpr (Left fields) -> do
rExprDoc <- docSharedWrapper layoutExpr rExpr rExprDoc <- docSharedWrapper layoutExpr rExpr
rFs <- rFs <-
fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do fields `forM` \lfield@(L _ (HsRecField _ (L _ ambName) rFExpr pun)) -> do
rFExpDoc <- if pun rFExpDoc <- if pun
then return Nothing then return Nothing
else Just <$> docSharedWrapper layoutExpr rFExpr else Just <$> docSharedWrapper layoutExpr rFExpr
@ -837,7 +838,11 @@ layoutExpr lexpr@(L _ expr) = do
Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
recordExpression False indentPolicy lexpr rExprDoc rFs 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 expDoc <- docSharedWrapper layoutExpr exp1
typDoc <- docSharedWrapper layoutType typ1 typDoc <- docSharedWrapper layoutType typ1
docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc]
@ -925,14 +930,21 @@ layoutExpr lexpr@(L _ expr) = do
HsPragE{} -> do HsPragE{} -> do
-- TODO -- TODO
briDocByExactInlineOnly "HsPragE{}" lexpr briDocByExactInlineOnly "HsPragE{}" lexpr
HsGetField{} -> do
-- TODO
briDocByExactInlineOnly "HsGetField{}" lexpr
HsProjection{} -> do
-- TODO
briDocByExactInlineOnly "HsProjection{}" lexpr
recordExpression recordExpression
:: (Data.Data.Data lExpr, Data.Data.Data name) :: (Data.Data.Data lExpr, Data.Data.Data name)
=> Bool => Bool
-> IndentPolicy -> IndentPolicy
-> GenLocated SrcSpan lExpr -> LocatedAn an1 lExpr
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> [ ( GenLocated SrcSpan name -> [ ( LocatedAn an2 name
, Text , Text
, Maybe (ToBriDocM BriDocNumbered) , Maybe (ToBriDocM BriDocNumbered)
) )
@ -1073,14 +1085,14 @@ litBriDoc = \case
HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i 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 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 HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t HsRat _ (FL (SourceText t) _ _ _ _) _type -> BDFLit $ Text.pack t
HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsFloatPrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsDoublePrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
_ -> error "litBriDoc: literal with no SourceText" _ -> error "litBriDoc: literal with no SourceText"
overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt
overLitValBriDoc = \case overLitValBriDoc = \case
HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t 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 HsIsString (SourceText t) _ -> BDFLit $ Text.pack t
_ -> error "overLitValBriDoc: literal with no SourceText" _ -> error "overLitValBriDoc: literal with no SourceText"

4
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
View File

@ -7,9 +7,7 @@ import Language.Haskell.Brittany.Internal.Types
layoutExpr :: ToBriDoc HsExpr layoutExpr :: ToBriDoc AnnListItem HsExpr
-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc :: HsLit GhcPs -> BriDocFInt

29
source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -23,17 +23,17 @@ import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> Located name prepareName :: LIEWrappedName name -> LocatedN name
prepareName = ieLWrappedName prepareName = ieLWrappedName
layoutIE :: ToBriDoc IE layoutIE :: ToBriDoc an IE
layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
IEVar _ x -> layoutWrapped lie x IEVar _ x -> layoutWrapped lie x
IEThingAbs _ x -> layoutWrapped lie x IEThingAbs _ x -> layoutWrapped lie x
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x (IEWildcard _) _ _ -> IEThingWith _ x (IEWildcard _) _ ->
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x _ ns _ -> do IEThingWith _ x _ ns -> do
hasComments <- orM hasComments <- orM
(hasCommentsBetween lie AnnOpenP AnnCloseP (hasCommentsBetween lie AnnOpenP AnnCloseP
: hasAnyCommentsBelow x : hasAnyCommentsBelow x
@ -78,10 +78,10 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
where where
layoutWrapped _ = \case layoutWrapped _ = \case
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
L _ (IEPattern n) -> do L _ (IEPattern _ n) -> do
name <- lrdrNameToTextAnn n name <- lrdrNameToTextAnn n
docLit $ Text.pack "pattern " <> name docLit $ Text.pack "pattern " <> name
L _ (IEType n) -> do L _ (IEType _ n) -> do
name <- lrdrNameToTextAnn n name <- lrdrNameToTextAnn n
docLit $ Text.pack "type " <> name docLit $ Text.pack "type " <> name
@ -95,7 +95,7 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- left to the caller since that is context sensitive -- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs layoutAnnAndSepLLIEs
:: SortItemsFlag :: SortItemsFlag
-> Located [LIE GhcPs] -> LocatedAn an [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered] -> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie] let makeIENode ie = docSeq [docCommaSep, ie]
@ -131,7 +131,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
isProperIEThing = \case isProperIEThing = \case
L _ (IEThingAbs _ _wn) -> True L _ (IEThingAbs _ _wn) -> True
L _ (IEThingAll _ _wn) -> True L _ (IEThingAll _ _wn) -> True
L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True L _ (IEThingWith _ _wn NoIEWildcard _) -> True
_ -> False _ -> False
isIEVar :: LIE GhcPs -> Bool isIEVar :: LIE GhcPs -> Bool
isIEVar = \case isIEVar = \case
@ -143,7 +143,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 (L _ IEThingAbs{}) = l1 thingFolder l1 (L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2 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
l l
(IEThingWith (IEThingWith
@ -151,7 +151,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
wn wn
NoIEWildcard NoIEWildcard
(consItems1 ++ consItems2) (consItems1 ++ consItems2)
(fieldLbls1 ++ fieldLbls2)
) )
thingFolder _ _ = thingFolder _ _ =
error "thingFolder should be exhaustive because we have a guard above" error "thingFolder should be exhaustive because we have a guard above"
@ -171,7 +170,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- ( -- a comment -- ( -- a comment
-- ) -- )
layoutLLIEs layoutLLIEs
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered :: Bool -> SortItemsFlag -> LocatedAn an [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
@ -199,8 +198,8 @@ layoutLLIEs enableSingleline shouldSort llies = do
wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case wrappedNameToText = \case
L _ (IEName n) -> lrdrNameToText n L _ (IEName n) -> lrdrNameToText n
L _ (IEPattern n) -> lrdrNameToText n L _ (IEPattern _ n) -> lrdrNameToText n
L _ (IEType n) -> lrdrNameToText n L _ (IEType _ n) -> lrdrNameToText n
-- | Returns a "fingerprint string", not a full text representation, nor even -- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node. -- a source code representation of this syntax node.
@ -210,7 +209,7 @@ lieToText = \case
L _ (IEVar _ wn) -> wrappedNameToText wn L _ (IEVar _ wn) -> wrappedNameToText wn
L _ (IEThingAbs _ wn) -> wrappedNameToText wn L _ (IEThingAbs _ wn) -> wrappedNameToText wn
L _ (IEThingAll _ wn) -> wrappedNameToText wn L _ (IEThingAll _ wn) -> wrappedNameToText wn
L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports! -- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some -- Need to check, and either put them at the top (for module) or do some
-- other clever thing. -- other clever thing.
@ -219,6 +218,6 @@ lieToText = \case
L _ IEDoc{} -> Text.pack "@IEDoc" L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed" L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where where
moduleNameToText :: Located ModuleName -> Text moduleNameToText :: LocatedAn an ModuleName -> Text
moduleNameToText (L _ name) = moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name) Text.pack ("@IEModuleContents" ++ moduleNameString name)

11
source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs
View File

@ -7,6 +7,7 @@ import qualified Data.Text as Text
import GHC (GenLocated(L), Located, moduleNameString, unLoc) import GHC (GenLocated(L), Located, moduleNameString, unLoc)
import GHC.Hs import GHC.Hs
import GHC.Types.Basic import GHC.Types.Basic
import qualified GHC.Types.SourceText
import GHC.Unit.Types (IsBootInterface(..)) import GHC.Unit.Types (IsBootInterface(..))
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics 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 prepPkg rawN = case rawN of
SourceText n -> n GHC.Types.SourceText.SourceText n -> n
-- This would be odd to encounter and the -- This would be odd to encounter and the
-- result will most certainly be wrong -- result will most certainly be wrong
NoSourceText -> "" GHC.Types.SourceText.NoSourceText -> ""
prepModName :: Located e -> e prepModName :: LocatedAn an e -> e
prepModName = unLoc prepModName = unLoc
layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
@ -36,7 +37,7 @@ layoutImport importD = case importD of
let let
compact = indentPolicy /= IndentPolicyFree compact = indentPolicy /= IndentPolicyFree
modNameT = Text.pack $ moduleNameString modName 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 masT = Text.pack . moduleNameString . prepModName <$> mas
hiding = maybe False fst mllies hiding = maybe False fst mllies
minQLength = length "import qualified " minQLength = length "import qualified "

40
source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -18,20 +18,21 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types
(DeltaPos(..), commentContents, deltaRow) (commentContents)
import Language.Haskell.Brittany.Internal.EPCompat (Annotation)
layoutModule :: ToBriDoc' an HsModule
layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of layoutModule lmod@(L _ mod') = case mod' of
-- Implicit module Main -- Implicit module Main
HsModule _ Nothing _ imports _ _ _ -> do HsModule _ _ Nothing _ imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
-- sortedImports <- sortImports imports -- sortedImports <- sortImports imports
-- docLines $ [layoutImport y i | (y, i) <- sortedImports] -- docLines $ [layoutImport y i | (y, i) <- sortedImports]
HsModule _ (Just n) les imports _ _ _ -> do HsModule _ _ (Just n) les imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports -- sortedImports <- sortImports imports
@ -99,11 +100,12 @@ transformToCommentedImport
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
transformToCommentedImport is = do transformToCommentedImport is = do
nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do
annotionMay <- astAnn i annotionMay <- undefined -- astAnn i
pure (annotionMay, rawImport) pure (annotionMay, rawImport)
let let
convertComment (c, DP (y, x)) = convertComment (c, _ {-DP (y, x)-}) =
replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] undefined
-- replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
accumF accumF
:: [(Comment, DeltaPos)] :: [(Comment, DeltaPos)]
-> (Maybe Annotation, ImportDecl GhcPs) -> (Maybe Annotation, ImportDecl GhcPs)
@ -120,21 +122,22 @@ transformToCommentedImport is = do
) )
Just ann -> Just ann ->
let let
blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 blanksBeforeImportDecl = undefined -- deltaRow (annEntryDelta ann) - 1
(newAccumulator, priorComments') = (newAccumulator, priorComments') =
List.span ((== 0) . deltaRow . snd) (annPriorComments ann) List.span ((== 0) . {-deltaRow-} undefined . snd) ({-annPriorComments-} undefined ann)
go go
:: [(Comment, DeltaPos)] :: [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
-> ([CommentedImport], [(Comment, DeltaPos)], Int) -> ([CommentedImport], [(Comment, DeltaPos)], Int)
go acc [] = ([], acc, 0) go acc [] = ([], acc, 0)
go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc _ = undefined
go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs -- go acc [c1@(_, {DP (y, _)})] = ([], c1 : acc, y - 1)
go acc ((c1, DP (y, x)) : xs) = -- go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine -- go acc ((c1, DP (y, x)) : xs) =
, (c1, DP (1, x)) : acc -- ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
, 0 -- , (c1, DP (1, x)) : acc
) -- , 0
-- )
(convertedIndependentComments, beforeComments, initialBlanks) = (convertedIndependentComments, beforeComments, initialBlanks) =
if blanksBeforeImportDecl /= 0 if blanksBeforeImportDecl /= 0
then (convertComment =<< priorComments', [], 0) then (convertComment =<< priorComments', [], 0)
@ -194,4 +197,5 @@ commentedImportsToDoc = \case
ImportStatement r -> docSeq ImportStatement r -> docSeq
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) (layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
where where
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) commentToDoc (c, _ {-DP (_y, x)-}) = undefined
-- docLitS (replicate x ' ' ++ commentContents c)

8
source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -57,7 +57,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- x1' <- docSeq [docLit $ Text.pack "(", return x1] -- x1' <- docSeq [docLit $ Text.pack "(", return x1]
-- xN' <- docSeq [return xN, docLit $ Text.pack ")"] -- xN' <- docSeq [return xN, docLit $ Text.pack ")"]
-- return $ (x1' Seq.<| middle) Seq.|> xN' -- return $ (x1' Seq.<| middle) Seq.|> xN'
ConPat _ lname (PrefixCon args) -> do ConPat _ lname (PrefixCon _tyargs args) -> do
-- Abc a b c -> expr -- Abc a b c -> expr
nameDoc <- lrdrNameToTextAnn lname nameDoc <- lrdrNameToTextAnn lname
argDocs <- layoutPat `mapM` args 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 = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2 -- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname 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 let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
@ -111,7 +111,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
| dotdoti == length fs -> do | dotdoti == length fs -> do
-- Abc { a = locA, .. } -- Abc { a = locA, .. }
let t = lrdrNameToText lname 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 let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
@ -171,7 +171,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
wrapPatPrepend pat1 (docLit $ Text.pack "~") wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do NPat _ llit@(L _ ol) mNegative _ -> do
-- -13 -> expr -- -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 "-" negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc] Just{} -> Seq.fromList [negDoc, litDoc]

4
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
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 layoutStmt lstmt@(L _ stmt) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
indentAmount :: Int <- indentAmount :: Int <-
@ -94,7 +94,7 @@ layoutStmt lstmt@(L _ stmt) = do
$ docPar $ docPar
(docLit $ Text.pack "let") (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs) (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do RecStmt _ (L _ stmts) _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1 -- rec stmt1
-- stmt2 -- stmt2
-- stmt3 -- stmt3

2
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
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))

31
source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -1,13 +1,15 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Haskell.Brittany.Internal.Layouters.Type where module Language.Haskell.Brittany.Internal.Layouters.Type where
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L)) import GHC (GenLocated(L))
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Types.Basic import GHC.Types.Basic
import qualified GHC.Types.SourceText
import GHC.Utils.Outputable (ftext, showSDocUnsafe) import GHC.Utils.Outputable (ftext, showSDocUnsafe)
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
@ -17,8 +19,8 @@ import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast) (FirstLastView(..), splitFirstLast)
--- XXX: maybe push `Anno (sym GhcPs)` into ToBriDoc definition in place of a typevar
layoutType :: ToBriDoc HsType layoutType :: ToBriDoc AnnListItem HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
HsTyVar _ promoted name -> do HsTyVar _ promoted name -> do
@ -26,7 +28,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
case promoted of case promoted of
IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
NotPromoted -> 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 let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2 typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs 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 typeDoc <- docSharedWrapper layoutType typ1
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let let
@ -291,8 +293,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
HsTupleTy _ tupleSort typs -> case tupleSort of HsTupleTy _ tupleSort typs -> case tupleSort of
HsUnboxedTuple -> unboxed HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple
HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple
where where
unboxed = if null typs unboxed = if null typs
@ -573,11 +573,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsExplicitTupleTy{} -> -- TODO HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
HsTyLit _ lit -> case lit of HsTyLit _ lit -> case lit of
HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsNumTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
HsNumTy NoSourceText _ -> HsNumTy GHC.Types.SourceText.NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText" error "overLitValBriDoc: literal with no SourceText"
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ -> 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" error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> docLit $ Text.pack "_" HsWildCardTy _ -> docLit $ Text.pack "_"
HsSumTy{} -> -- TODO HsSumTy{} -> -- TODO
@ -622,14 +625,12 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] getBinders :: HsForAllTelescope (GhcPass pass) -> [LHsTyVarBndr () (GhcPass pass)]
getBinders x = case x of getBinders x = case x of
HsForAllVis _ b -> b HsForAllVis _ b -> b
HsForAllInvis _ b -> fmap withoutSpecificity b HsForAllInvis _ b -> fmap withoutSpecificity b
XHsForAllTelescope _ -> []
withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass withoutSpecificity :: LHsTyVarBndr flag (GhcPass pass) -> LHsTyVarBndr () (GhcPass pass)
withoutSpecificity = fmap $ \case withoutSpecificity = fmap $ \case
UserTyVar a _ c -> UserTyVar a () c UserTyVar a _ c -> UserTyVar a () c
KindedTyVar a _ c d -> KindedTyVar a () c d KindedTyVar a _ c d -> KindedTyVar a () c d
XTyVarBndr a -> XTyVarBndr a

285
source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
View File

@ -13,11 +13,11 @@ import qualified GHC.Driver.Session
import qualified GHC.Parser.Header import qualified GHC.Parser.Header
import qualified GHC.Platform import qualified GHC.Platform
import qualified GHC.Settings import qualified GHC.Settings
import qualified GHC.Types.SafeHaskell
import qualified GHC.Types.SrcLoc import qualified GHC.Types.SrcLoc
import qualified GHC.Utils.Error import qualified GHC.Utils.Error
import qualified GHC.Utils.Fingerprint import qualified GHC.Utils.Fingerprint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint 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 -- | Parses a Haskell module. Although this nominally requires IO, it is
-- morally pure. It should have no observable effects. -- morally pure. It should have no observable effects.
@ -27,7 +27,7 @@ parseModule
-> FilePath -> FilePath
-> (GHC.Driver.Session.DynFlags -> io (Either String a)) -> (GHC.Driver.Session.DynFlags -> io (Either String a))
-> String -> String
-> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -> io (Either String (GHC.ParsedSource, a))
parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
let let
dynFlags1 = GHC.Driver.Session.gopt_set 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 -- Neither passing in @"-XUnsafe"@ as a command line argument nor having
-- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
initialDynFlags initialDynFlags
{ GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe { GHC.Driver.Session.safeHaskell = GHC.Types.SafeHaskell.Sf_Unsafe
} }
GHC.Driver.Session.Opt_KeepRawTokenStream GHC.Driver.Session.Opt_KeepRawTokenStream
(dynFlags2, leftovers1, _) <- (dynFlags2, leftovers1, _) <-
@ -56,7 +56,7 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
case parseResult of case parseResult of
Left errorMessages -> handleErrorMessages errorMessages Left errorMessages -> handleErrorMessages errorMessages
Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) Right parsedSource -> pure (parsedSource, dynFlagsResult)
handleLeftovers handleLeftovers
:: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () :: 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.sTargetPlatform = initialTargetPlatform
, GHC.Driver.Session.sToolSettings = initialToolSettings , GHC.Driver.Session.sToolSettings = initialToolSettings
, GHC.Driver.Session.sPlatformMisc = initialPlatformMisc , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc
, GHC.Driver.Session.sPlatformConstants = initialPlatformConstants
, GHC.Driver.Session.sRawSettings = [] , GHC.Driver.Session.sRawSettings = []
} }
@ -101,10 +100,8 @@ initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion
initialPlatformMisc :: GHC.Driver.Session.PlatformMisc initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
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_ghcRtsWithLibdw = False
, GHC.Driver.Session.platformMisc_ghcThreaded = False
, GHC.Driver.Session.platformMisc_ghcWithInterpreter = False , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False
, GHC.Driver.Session.platformMisc_ghcWithSMP = False , GHC.Driver.Session.platformMisc_ghcWithSMP = False
, GHC.Driver.Session.platformMisc_libFFI = False , GHC.Driver.Session.platformMisc_libFFI = False
@ -118,143 +115,142 @@ initialLlvmConfig = GHC.Driver.Session.LlvmConfig
, GHC.Driver.Session.llvmTargets = [] , GHC.Driver.Session.llvmTargets = []
} }
initialPlatformConstants :: GHC.Settings.PlatformConstants initialPlatformConstants :: GHC.Platform.PlatformConstants
initialPlatformConstants = GHC.Settings.PlatformConstants initialPlatformConstants = GHC.Platform.PlatformConstants
{ GHC.Settings.pc_AP_STACK_SPLIM = 0 { GHC.Platform.pc_AP_STACK_SPLIM = 0
, GHC.Settings.pc_BITMAP_BITS_SHIFT = 0 , GHC.Platform.pc_BITMAP_BITS_SHIFT = 0
, GHC.Settings.pc_BLOCK_SIZE = 0 , GHC.Platform.pc_BLOCK_SIZE = 0
, GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0 , GHC.Platform.pc_BLOCKS_PER_MBLOCK = 0
, GHC.Settings.pc_CINT_SIZE = 0 , GHC.Platform.pc_CINT_SIZE = 0
, GHC.Settings.pc_CLONG_LONG_SIZE = 0 , GHC.Platform.pc_CLONG_LONG_SIZE = 0
, GHC.Settings.pc_CLONG_SIZE = 0 , GHC.Platform.pc_CLONG_SIZE = 0
, GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0 , GHC.Platform.pc_CONTROL_GROUP_CONST_291 = 0
, GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False , GHC.Platform.pc_ILDV_CREATE_MASK = 0
, GHC.Settings.pc_ILDV_CREATE_MASK = 0 , GHC.Platform.pc_ILDV_STATE_CREATE = 0
, GHC.Settings.pc_ILDV_STATE_CREATE = 0 , GHC.Platform.pc_ILDV_STATE_USE = 0
, GHC.Settings.pc_ILDV_STATE_USE = 0 , GHC.Platform.pc_LDV_SHIFT = 0
, GHC.Settings.pc_LDV_SHIFT = 0 , GHC.Platform.pc_MAX_CHARLIKE = 0
, GHC.Settings.pc_MAX_CHARLIKE = 0 , GHC.Platform.pc_MAX_Double_REG = 0
, GHC.Settings.pc_MAX_Double_REG = 0 , GHC.Platform.pc_MAX_Float_REG = 0
, GHC.Settings.pc_MAX_Float_REG = 0 , GHC.Platform.pc_MAX_INTLIKE = 0
, GHC.Settings.pc_MAX_INTLIKE = 0 , GHC.Platform.pc_MAX_Long_REG = 0
, GHC.Settings.pc_MAX_Long_REG = 0 , GHC.Platform.pc_MAX_Real_Double_REG = 0
, GHC.Settings.pc_MAX_Real_Double_REG = 0 , GHC.Platform.pc_MAX_Real_Float_REG = 0
, GHC.Settings.pc_MAX_Real_Float_REG = 0 , GHC.Platform.pc_MAX_Real_Long_REG = 0
, GHC.Settings.pc_MAX_Real_Long_REG = 0 , GHC.Platform.pc_MAX_Real_Vanilla_REG = 0
, GHC.Settings.pc_MAX_Real_Vanilla_REG = 0 , GHC.Platform.pc_MAX_Real_XMM_REG = 0
, GHC.Settings.pc_MAX_Real_XMM_REG = 0 , GHC.Platform.pc_MAX_SPEC_AP_SIZE = 0
, GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0 , GHC.Platform.pc_MAX_SPEC_SELECTEE_SIZE = 0
, GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0 , GHC.Platform.pc_MAX_Vanilla_REG = 0
, GHC.Settings.pc_MAX_Vanilla_REG = 0 , GHC.Platform.pc_MAX_XMM_REG = 0
, GHC.Settings.pc_MAX_XMM_REG = 0 , GHC.Platform.pc_MIN_CHARLIKE = 0
, GHC.Settings.pc_MIN_CHARLIKE = 0 , GHC.Platform.pc_MIN_INTLIKE = 0
, GHC.Settings.pc_MIN_INTLIKE = 0 , GHC.Platform.pc_MIN_PAYLOAD_SIZE = 0
, GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0 , GHC.Platform.pc_MUT_ARR_PTRS_CARD_BITS = 0
, GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0 , GHC.Platform.pc_OFFSET_bdescr_blocks = 0
, GHC.Settings.pc_OFFSET_bdescr_blocks = 0 , GHC.Platform.pc_OFFSET_bdescr_flags = 0
, GHC.Settings.pc_OFFSET_bdescr_flags = 0 , GHC.Platform.pc_OFFSET_bdescr_free = 0
, GHC.Settings.pc_OFFSET_bdescr_free = 0 , GHC.Platform.pc_OFFSET_bdescr_start = 0
, GHC.Settings.pc_OFFSET_bdescr_start = 0 , GHC.Platform.pc_OFFSET_Capability_r = 0
, GHC.Settings.pc_OFFSET_Capability_r = 0 , GHC.Platform.pc_OFFSET_CostCentreStack_mem_alloc = 0
, GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0 , GHC.Platform.pc_OFFSET_CostCentreStack_scc_count = 0
, GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0 , GHC.Platform.pc_OFFSET_StgArrBytes_bytes = 0
, GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0 , GHC.Platform.pc_OFFSET_stgEagerBlackholeInfo = 0
, GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_allocd = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_allocs = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_entry_count = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_link = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_link = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_registeredp = 0
, GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0 , GHC.Platform.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
, GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 , GHC.Platform.pc_OFFSET_StgFunInfoExtraRev_arity = 0
, GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0 , GHC.Platform.pc_OFFSET_stgGCEnter1 = 0
, GHC.Settings.pc_OFFSET_stgGCEnter1 = 0 , GHC.Platform.pc_OFFSET_stgGCFun = 0
, GHC.Settings.pc_OFFSET_stgGCFun = 0 , GHC.Platform.pc_OFFSET_StgHeader_ccs = 0
, GHC.Settings.pc_OFFSET_StgHeader_ccs = 0 , GHC.Platform.pc_OFFSET_StgHeader_ldvw = 0
, GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0 , GHC.Platform.pc_OFFSET_StgMutArrPtrs_ptrs = 0
, GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0 , GHC.Platform.pc_OFFSET_StgMutArrPtrs_size = 0
, GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rCCCS = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentNursery = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentTSO = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rHp = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rHpAlloc = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rHpLim = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rL1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR10 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR7 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR8 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR9 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rSp = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rSpLim = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM1 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM2 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM3 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM4 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM5 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM6 = 0
, GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0 , GHC.Platform.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
, GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 , GHC.Platform.pc_OFFSET_StgStack_sp = 0
, GHC.Settings.pc_OFFSET_StgStack_sp = 0 , GHC.Platform.pc_OFFSET_StgStack_stack = 0
, GHC.Settings.pc_OFFSET_StgStack_stack = 0 , GHC.Platform.pc_OFFSET_StgTSO_alloc_limit = 0
, GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0 , GHC.Platform.pc_OFFSET_StgTSO_cccs = 0
, GHC.Settings.pc_OFFSET_StgTSO_cccs = 0 , GHC.Platform.pc_OFFSET_StgTSO_stackobj = 0
, GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0 , GHC.Platform.pc_OFFSET_StgUpdateFrame_updatee = 0
, GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0 , GHC.Platform.pc_PROF_HDR_SIZE = 0
, GHC.Settings.pc_PROF_HDR_SIZE = 0 , GHC.Platform.pc_REP_CostCentreStack_mem_alloc = 0
, GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0 , GHC.Platform.pc_REP_CostCentreStack_scc_count = 0
, GHC.Settings.pc_REP_CostCentreStack_scc_count = 0 , GHC.Platform.pc_REP_StgEntCounter_allocd = 0
, GHC.Settings.pc_REP_StgEntCounter_allocd = 0 , GHC.Platform.pc_REP_StgEntCounter_allocs = 0
, GHC.Settings.pc_REP_StgEntCounter_allocs = 0 , GHC.Platform.pc_REP_StgFunInfoExtraFwd_arity = 0
, GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0 , GHC.Platform.pc_REP_StgFunInfoExtraRev_arity = 0
, GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0 , GHC.Platform.pc_RESERVED_C_STACK_BYTES = 0
, GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0 , GHC.Platform.pc_RESERVED_STACK_WORDS = 0
, GHC.Settings.pc_RESERVED_STACK_WORDS = 0 , GHC.Platform.pc_SIZEOF_CostCentreStack = 0
, GHC.Settings.pc_SIZEOF_CostCentreStack = 0 , GHC.Platform.pc_SIZEOF_StgArrBytes_NoHdr = 0
, GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0 , GHC.Platform.pc_SIZEOF_StgFunInfoExtraRev = 0
, GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0 , GHC.Platform.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
, GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 , GHC.Platform.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
, GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 , GHC.Platform.pc_SIZEOF_StgSMPThunkHeader = 0
, GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0 , GHC.Platform.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
, GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 , GHC.Platform.pc_STD_HDR_SIZE = 0
, GHC.Settings.pc_STD_HDR_SIZE = 0 , GHC.Platform.pc_TAG_BITS = 0
, GHC.Settings.pc_TAG_BITS = 0 , GHC.Platform.pc_TICKY_BIN_COUNT = 0
, GHC.Settings.pc_TICKY_BIN_COUNT = 0 , GHC.Platform.pc_WORD_SIZE = 0
, GHC.Settings.pc_WORD_SIZE = 0
} }
initialPlatformMini :: GHC.Settings.PlatformMini initialPlatformArchOS :: GHC.Platform.ArchOS
initialPlatformMini = GHC.Settings.PlatformMini initialPlatformArchOS = GHC.Platform.ArchOS
{ GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 { GHC.Platform.archOS_arch = GHC.Platform.ArchX86_64
, GHC.Settings.platformMini_os = GHC.Platform.OSLinux , GHC.Platform.archOS_OS = GHC.Platform.OSLinux
} }
initialTargetPlatform :: GHC.Settings.Platform initialTargetPlatform :: GHC.Settings.Platform
@ -265,7 +261,8 @@ initialTargetPlatform = GHC.Settings.Platform
, GHC.Settings.platformHasSubsectionsViaSymbols = False , GHC.Settings.platformHasSubsectionsViaSymbols = False
, GHC.Settings.platformIsCrossCompiling = False , GHC.Settings.platformIsCrossCompiling = False
, GHC.Settings.platformLeadingUnderscore = 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.platformTablesNextToCode = False
, GHC.Settings.platformUnregisterised = False , GHC.Settings.platformUnregisterised = False
, GHC.Settings.platformWordSize = GHC.Platform.PW8 , GHC.Settings.platformWordSize = GHC.Platform.PW8

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

@ -18,33 +18,34 @@ import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy.Builder as Text.Builder 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.Config.Types
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint 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 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 qualified Safe
import Language.Haskell.Brittany.Internal.EPCompat
data PerItemConfig = PerItemConfig data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe) { _icd_perBinding :: Map String (CConfig Maybe)
, _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) , _icd_perKey :: Map AnnKey (CConfig Maybe)
} }
deriving Data.Data.Data deriving Data.Data.Data
type PPM = MultiRWSS.MultiRWS 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] '[Text.Builder.Builder, [BrittanyError], Seq String]
'[] '[]
type PPMLocal = MultiRWSS.MultiRWS type PPMLocal = MultiRWSS.MultiRWS
'[Config, ExactPrint.Anns] '[Config, Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String] '[Text.Builder.Builder, [BrittanyError], Seq String]
'[] '[]
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map AnnKey String)
data LayoutState = LayoutState data LayoutState = LayoutState
{ _lstate_baseYs :: [Int] { _lstate_baseYs :: [Int]
@ -131,7 +132,7 @@ instance Show LayoutState where
-- -- when creating zero-indentation -- -- when creating zero-indentation
-- -- multi-line list literals. -- -- multi-line list literals.
-- , _lsettings_importColumn :: Int -- , _lsettings_importColumn :: Int
-- , _lsettings_initialAnns :: ExactPrint.Anns -- , _lsettings_initialAnns :: Anns
-- } -- }
data BrittanyError data BrittanyError
@ -144,7 +145,7 @@ data BrittanyError
-- output and second the corresponding, ill-formed input. -- output and second the corresponding, ill-formed input.
| LayoutWarning String | LayoutWarning String
-- ^ some warning -- ^ 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 -- ^ internal error: pretty-printing is not implemented for type of node
-- in the syntax-tree -- in the syntax-tree
| ErrorOutputCheck | ErrorOutputCheck
@ -218,9 +219,9 @@ type ToBriDocM = MultiRWSS.MultiRWS
'[[BrittanyError], Seq String] -- writer '[[BrittanyError], Seq String] -- writer
'[NodeAllocIndex] -- state '[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc an (sym :: Kind.Type -> Kind.Type) = LocatedAn an (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered type ToBriDoc' an sym = LocatedAn an sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c type ToBriDocC an sym c = LocatedAn an sym -> ToBriDocM c
data DocMultiLine data DocMultiLine
= MultiLineNo = MultiLineNo

23
source/library/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -17,9 +17,10 @@ import qualified Data.Sequence as Seq
import DataTreePrint import DataTreePrint
import qualified GHC.Data.FastString as GHC import qualified GHC.Data.FastString as GHC
import qualified GHC.Driver.Session 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 qualified GHC.OldList as List
import GHC.Types.Name.Occurrence as OccName (occNameString) 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.Types.SrcLoc as GHC
import qualified GHC.Utils.Outputable as GHC import qualified GHC.Utils.Outputable as GHC
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
@ -28,8 +29,10 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.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.GHC.ExactPrint.Utils as ExactPrint.Utils
import qualified Language.Haskell.Syntax.Extension as HsExtension
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import Language.Haskell.Brittany.Internal.EPCompat
parDoc :: String -> PP.Doc parDoc :: String -> PP.Doc
@ -40,10 +43,10 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords
showSDoc_ :: GHC.SDoc -> String showSDoc_ :: GHC.SDoc -> String
showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags showSDoc_ = GHC.showSDoc undefined -- GHC.unsafeGlobalDynFlags
showOutputable :: (GHC.Outputable a) => a -> String 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 :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y 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 data A x = A ShowIsId x
deriving Data deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF :: LayouterF
customLayouterF anns layoutF = customLayouterF layoutF =
DataToLayouter DataToLayouter
$ f $ f
`extQ` showIsId `extQ` showIsId
@ -104,12 +107,12 @@ customLayouterF anns layoutF =
$ "{" $ "{"
++ showOutputable ss ++ 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 located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where where
annStr = case cast ss of annStr = case cast ss of
Just (s :: GHC.SrcSpan) -> Just (s :: GHC.SrcLoc) ->
ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) ShowIsId $ "printing anns on 9.2.1: not implemented" ++ undefined
Nothing -> ShowIsId "nnnnnnnn" Nothing -> ShowIsId "nnnnnnnn"
customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF :: LayouterF
@ -226,9 +229,9 @@ briDocToDoc = astToDoc . removeAnnotations
briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc :: EPAnns -> PP.Doc
annsDoc = annsDoc =
printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) printTreeWithCustom 100 customLayouterNoAnnsF
breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], []) breakEither _ [] = ([], [])