{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-- TODO92
module Language.Haskell.Brittany.Internal.S2_SplitModule
( extractDeclMap
, splitModuleDecls
, splitModuleStart
) where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.Generics as SYB
import qualified Data.Map as Map
import qualified GHC
import GHC ( AddEpAnn(AddEpAnn)
, Anchor(Anchor)
, EpAnn(EpAnn, EpAnnNotUsed)
, EpAnnComments
( EpaComments
, EpaCommentsBalanced
)
, EpaComment(EpaComment)
, EpaCommentTok
( EpaBlockComment
, EpaDocCommentNamed
, EpaDocCommentNext
, EpaDocCommentPrev
, EpaDocOptions
, EpaDocSection
, EpaEofComment
, EpaLineComment
)
, EpaLocation(EpaSpan)
, GenLocated(L)
, HsModule(HsModule)
, LEpaComment
, LHsDecl
, LImportDecl
, SrcSpan
( RealSrcSpan
, UnhelpfulSpan
)
, SrcSpanAnn'(SrcSpanAnn)
, anchor
, ideclName
, moduleNameString
, srcLocCol
, srcLocLine
, unLoc
)
import qualified GHC.OldList as List
import GHC.Parser.Annotation ( DeltaPos
( DifferentLine
, SameLine
)
, EpaCommentTok(EpaEofComment)
)
import GHC.Types.SrcLoc ( realSrcSpanEnd
, realSrcSpanStart
)
import qualified Language.Haskell.GHC.ExactPrint.Types
as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils
as ExactPrint
import Safe ( maximumMay )
import qualified Control.Monad.Trans.Writer.Strict
as WriterS
import Language.Haskell.Brittany.Internal.Components.BriDoc
import Language.Haskell.Brittany.Internal.ToBriDoc.Module
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Util.AST
extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String]
extractDeclMap modul =
Map.fromList
[ ( case span of
GHC.RealSrcSpan s _ -> s
GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
, getDeclBindingNames decl
)
| decl <- decls
, let (L (GHC.SrcSpanAnn _ span) _) = decl
]
where (L _ (GHC.HsModule _ _ _ _ _ decls _ _)) = modul
splitModuleDecls :: GHC.ParsedSource -> FinalList ModuleElement ExactPrint.Pos
splitModuleDecls lmod = do
let L moduleSpan modl = lmod
HsModule _ _layout _name _exports _imports decls _ _ = modl
(hsModAnn', finalComments) = case GHC.hsmodAnn modl of
EpAnn a modAnns (EpaCommentsBalanced prior post) ->
(EpAnn a modAnns (EpaCommentsBalanced prior []), post)
_ -> (GHC.hsmodAnn modl, [])
moduleWithoutComments = L moduleSpan modl { GHC.hsmodAnn = hsModAnn'
, GHC.hsmodDecls = []
}
lastSpan <- do
finalYield $ MEExactModuleHead moduleWithoutComments
pure
$ maybe (1, 1) (ExactPrint.ss2posEnd)
$ maximumMay
$ [ GHC.anchor a
| L a _ <- GHC.priorComments $ case hsModAnn' of
EpAnn _ _ cs -> cs
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
]
++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
++ [ GHC.anchor a
| L da _ <- GHC.hsmodImports modl
, L a _ <- case GHC.ann da of
EpAnn _ _ (EpaComments l ) -> l
EpAnn _ _ (EpaCommentsBalanced _ l) -> l
EpAnnNotUsed -> []
]
++ [ span
| L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports modl
]
spanAfterDecls <- enrichDecls lastSpan decls
enrichComms spanAfterDecls finalComments
splitModuleStart
:: GHC.ParsedSource
-> Maybe GHC.RealSrcLoc
-> FinalList ModuleElement ExactPrint.Pos
splitModuleStart modul posWhere = do
finalYield $ MEPrettyModuleHead modul
let locBeforeImports =
maximumMay
$ [ realSrcSpanEnd $ anchor a
| L a _ <- case GHC.hsmodAnn $ unLoc modul of
EpAnn _ _ (EpaComments cs ) -> cs
EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
]
++ [ pos | Just pos <- [posWhere] ]
let (importLines, lastSpan) = finalToList $ transformToImportLine
( maybe 0 srcLocLine locBeforeImports
, maybe 1 srcLocCol locBeforeImports
)
(GHC.hsmodImports $ unLoc modul)
let commentedImports = groupifyImportLines importLines
sortCommentedImports commentedImports `forM_` \case
EmptyLines n -> finalYield $ MEWhitespace $ DifferentLine n 1
SamelineComment{} ->
error "brittany internal error: splitModuleStart SamelineComment"
NewlineComment comm -> finalYield $ MEComment comm
ImportStatement record -> do
forM_ (commentsBefore record) $ finalYield . MEComment
finalYield $ MEImportDecl (importStatement record)
(commentsSameline record)
forM_ (commentsAfter record) $ finalYield . MEComment
pure $ lastSpan
enrichComms
:: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos
enrichComms lastSpanEnd = \case
[] -> pure lastSpanEnd
(L (Anchor span _) (EpaComment EpaEofComment _) : commRest) -> do
finalYield $ MEWhitespace $ case ExactPrint.ss2delta lastSpanEnd span of -- TODO92 move this (l-1) bit into utility function
SameLine i -> SameLine i
DifferentLine l c -> DifferentLine (l - 1) c
enrichComms (ExactPrint.ss2posEnd span) commRest
lcomm@(L (Anchor span _) _) : commRest -> do
case ExactPrint.ss2delta lastSpanEnd span of
SameLine i -> do
finalYield $ MEComment (i, lcomm)
DifferentLine l c -> do
finalYield $ MEWhitespace $ DifferentLine (l - 1) c
finalYield $ MEComment (0, lcomm)
enrichComms (ExactPrint.ss2posEnd span) commRest
enrichDecls
:: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos
enrichDecls lastSpanEnd = \case
[] -> finalPure $ lastSpanEnd
ldecl@(L (SrcSpanAnn dAnn (GHC.RealSrcSpan span _)) _) : declRest ->
case dAnn of
EpAnn _dAnchor _items (EpaComments _dComments) -> do
let
commentExtract
:: [LEpaComment] -> WriterS.Writer [LEpaComment] [LEpaComment]
commentExtract comms = do
let (innerComments, outerComments) =
partition
(\(L (Anchor anch _) _) ->
( realSrcSpanStart anch < realSrcSpanEnd span
&& realSrcSpanEnd anch > realSrcSpanStart span
)
)
comms
WriterS.tell outerComments
pure innerComments
(ldecl', extractedComments) = WriterS.runWriter
$ SYB.everywhereM (SYB.mkM commentExtract) ldecl
case ExactPrint.ss2delta lastSpanEnd span of
SameLine{} -> pure ()
DifferentLine n _ ->
finalYield $ MEWhitespace $ DifferentLine (n - 1) 1
let fixedSpanEnd = ExactPrint.ss2posEnd span
let (afterComms, span2) = finalToList
$ enrichComms fixedSpanEnd
(List.sortOn (\(L l _) -> l) extractedComments)
let (immediate, later) =
List.span
(\case
MEComment{} -> True
_ -> False
)
afterComms
finalYield
$ MEDecl
ldecl'
[ (ind, GHC.ac_tok comm) | MEComment (ind, L _ comm) <- immediate ]
later `forM_` finalYield
enrichDecls span2 declRest
EpAnn _anchor _items (EpaCommentsBalanced{}) ->
error "EpaCommentsBalanced"
EpAnnNotUsed -> error "EpAnnNotUsed"
(L (SrcSpanAnn _ann (GHC.UnhelpfulSpan{})) _decl : _declRest) ->
error "UnhelpfulSpan"
-- module head pretty-printing
data ImportLine
= EmptyLines Int
| SamelineComment (Int, LEpaComment)
| NewlineComment (Int, LEpaComment) -- indentation and comment
| ImportStatement ImportStatementRecord
instance Show ImportLine where
show = \case
EmptyLines n -> "EmptyLines " ++ show n
SamelineComment{} -> "SamelineComment"
NewlineComment{} -> "NewlineComment"
ImportStatement r ->
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
data ImportStatementRecord = ImportStatementRecord
{ commentsBefore :: [(Int, LEpaComment)]
, importStatement :: LImportDecl GhcPs
, commentsSameline :: [(Int, EpaCommentTok)]
, commentsAfter :: [(Int, LEpaComment)]
}
instance Show ImportStatementRecord where
show r =
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
transformToImportLine
:: ExactPrint.Pos
-> [LImportDecl GhcPs]
-> FinalList ImportLine ExactPrint.Pos
transformToImportLine startPos is =
let
flattenComms
:: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos
flattenComms = \case
[] -> finalPure
lcomm@(L (Anchor span _) _) : commRest -> \lastSpanEnd -> do
case ExactPrint.ss2delta lastSpanEnd span of
SameLine i -> do
finalYield $ SamelineComment (i, lcomm)
DifferentLine l c -> do
finalYield $ EmptyLines (l - 1)
finalYield $ NewlineComment (c - 1, lcomm)
flattenComms commRest (ExactPrint.ss2posEnd span)
flattenDecls
:: [LImportDecl GhcPs]
-> ExactPrint.Pos
-> FinalList ImportLine ExactPrint.Pos
flattenDecls = \case
[] -> finalPure
(L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest)
-> \lastSpanEnd ->
let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of
EpAnn anch s (EpaComments cs) ->
([], reverse cs, EpAnn anch s (EpaComments []))
EpAnn anch s (EpaCommentsBalanced cs1 cs2) ->
(reverse cs1, reverse cs2, EpAnn anch s (EpaComments []))
EpAnnNotUsed -> ([], [], EpAnnNotUsed)
in do
span1 <- flattenComms commsBefore lastSpanEnd
let newlines = case ExactPrint.ss2delta span1 declSpan of
SameLine _ -> 0
DifferentLine i _ -> i - 1
finalYield $ EmptyLines newlines
finalYield $ ImportStatement ImportStatementRecord
{ commentsBefore = []
, importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl
, commentsSameline = []
, commentsAfter = []
}
span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
flattenDecls declRest span2
(L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) ->
error "UnhelpfulSpan"
in
flattenDecls is startPos
data Partial = PartialCommsOnly [(Int, LEpaComment)]
| PartialImport ImportStatementRecord
groupifyImportLines :: [ImportLine] -> [ImportLine]
groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
where
go acc [] = case acc of
PartialCommsOnly comms -> reverse comms `forM_` \comm ->
finalYield $ NewlineComment comm
PartialImport partialRecord ->
finalYield $ ImportStatement $ unpartial partialRecord
go acc (line1 : lineR) = do
newAcc <- case acc of
PartialCommsOnly comms -> case line1 of
e@EmptyLines{} -> do
reverse comms `forM_` \comm -> finalYield $ NewlineComment comm
finalYield e
pure $ PartialCommsOnly []
SamelineComment comm -> do
pure $ PartialCommsOnly (comm : comms)
NewlineComment comm -> pure $ PartialCommsOnly (comm : comms)
ImportStatement record -> pure $ PartialImport $ record
{ commentsBefore = comms
}
PartialImport partialRecord -> case line1 of
e@EmptyLines{} -> do
finalYield $ ImportStatement $ unpartial partialRecord
finalYield e
pure $ PartialCommsOnly []
SamelineComment comm -> do
if (null $ commentsAfter partialRecord)
then pure $ PartialImport partialRecord
{ commentsSameline = tokenOnly comm
: commentsSameline partialRecord
}
else pure $ PartialImport partialRecord
{ commentsAfter = comm : commentsAfter partialRecord
}
NewlineComment comm -> pure $ PartialImport $ partialRecord
{ commentsAfter = comm : commentsAfter partialRecord
}
ImportStatement record -> do
let contestedComments = commentsAfter partialRecord
finalYield $ ImportStatement $ unpartial $ partialRecord
{ commentsAfter = []
}
pure $ PartialImport $ record { commentsBefore = contestedComments }
-- comments in between will stay connected to the following decl
go newAcc lineR
tokenOnly :: (Int, LEpaComment) -> (Int, EpaCommentTok)
tokenOnly (ind, L _ (EpaComment tok _)) = (ind, tok)
unpartial :: ImportStatementRecord -> ImportStatementRecord
unpartial partialRecord = ImportStatementRecord
{ commentsBefore = reverse (commentsBefore partialRecord)
, importStatement = importStatement partialRecord
, commentsSameline = reverse (commentsSameline partialRecord)
, commentsAfter = reverse (commentsAfter partialRecord)
}
sortCommentedImports :: [ImportLine] -> [ImportLine]
sortCommentedImports =
-- TODO92 we don't need this unpackImports, it is implied later in the process
mergeGroups . map (fmap (sortGroups)) . groupify
where
-- unpackImports :: [ImportLine] -> [ImportLine]
-- unpackImports xs = xs >>= \case
-- l@EmptyLines{} -> [l]
-- l@NewlineComment{} -> [l]
-- l@SamelineComment{} -> [l]
-- ImportStatement r ->
-- map NewlineComment (commentsBefore r) ++ [ImportStatement r] ++ map
-- NewlineComment
-- (commentsAfter r)
mergeGroups :: [Either ImportLine [ImportStatementRecord]] -> [ImportLine]
mergeGroups xs = xs >>= \case
Left x -> [x]
Right y -> ImportStatement <$> y
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
sortGroups = List.sortOn
(moduleNameString . unLoc . ideclName . unLoc . importStatement)
groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
groupify cs = go [] cs
where
go [] = \case
(l@EmptyLines{} : rest) -> Left l : go [] rest
(l@NewlineComment{} : rest) -> Left l : go [] rest
(l@SamelineComment{} : rest) -> Left l : go [] rest
(ImportStatement r : rest) -> go [r] rest
[] -> []
go acc = \case
(l@EmptyLines{} : rest) -> Right (reverse acc) : Left l : go [] rest
(l@NewlineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest
(l@SamelineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest
(ImportStatement r : rest) -> go (r : acc) rest
[] -> [Right (reverse acc)]