{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Module
( p_hsModule,
)
where
import Control.Monad
import GHC.Hs hiding (comment)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable (ppr, showSDocUnsafe)
import Ormolu.Config
import Ormolu.Imports (normalizeImports)
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Pragma
import Ormolu.Printer.Combinators
import Ormolu.Printer.Comments
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Declaration
import Ormolu.Printer.Meat.Declaration.Warning
import Ormolu.Printer.Meat.ImportExport
import Ormolu.Printer.Meat.Pragma
p_hsModule ::
Maybe LComment ->
[([LComment], Pragma)] ->
HsModule GhcPs ->
R ()
p_hsModule :: Maybe LComment -> [([LComment], Pragma)] -> HsModule GhcPs -> R ()
p_hsModule Maybe LComment
mstackHeader [([LComment], Pragma)]
pragmas hsmod :: HsModule GhcPs
hsmod@HsModule {[LImportDecl GhcPs]
[LHsDecl GhcPs]
Maybe (XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
XCModule GhcPs
hsmodExt :: XCModule GhcPs
hsmodName :: Maybe (XRec GhcPs ModuleName)
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodImports :: [LImportDecl GhcPs]
hsmodDecls :: [LHsDecl GhcPs]
hsmodExt :: forall p. HsModule p -> XCModule p
hsmodName :: forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodExports :: forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodImports :: forall p. HsModule p -> [LImportDecl p]
hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
..} = do
let XModulePs {Maybe (LWarningTxt GhcPs)
Maybe (LHsDoc GhcPs)
EpAnn AnnsModule
EpLayout
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: EpLayout
hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodLayout :: XModulePs -> EpLayout
hsmodDeprecMessage :: XModulePs -> Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
..} = XCModule GhcPs
hsmodExt
deprecSpan :: [SrcSpan]
deprecSpan = [SrcSpan]
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> [SrcSpan])
-> Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (SrcSpan -> [SrcSpan]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> [SrcSpan])
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> SrcSpan)
-> GenLocated SrcSpanAnnP (WarningTxt GhcPs)
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA) Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
hsmodDeprecMessage
exportSpans :: [SrcSpan]
exportSpans = [SrcSpan]
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [SrcSpan])
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (SrcSpan -> [SrcSpan]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> [SrcSpan])
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpan)
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA) Maybe (XRec GhcPs [LIE GhcPs])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
hsmodExports
[SrcSpan] -> R () -> R ()
switchLayout ([SrcSpan]
deprecSpan [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. Semigroup a => a -> a -> a
<> [SrcSpan]
exportSpans) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
Maybe LComment -> (LComment -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LComment
mstackHeader ((LComment -> R ()) -> R ()) -> (LComment -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \(L RealSrcSpan
spn Comment
comment) -> do
RealSrcSpan -> Comment -> R ()
spitCommentNow RealSrcSpan
spn Comment
comment
R ()
newline
R ()
newline
[([LComment], Pragma)] -> R ()
p_pragmas [([LComment], Pragma)]
pragmas
R ()
newline
(LocatedA ModuleName -> R ())
-> Maybe (LocatedA ModuleName) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HsModule GhcPs -> LocatedA ModuleName -> R ()
p_hsModuleHeader HsModule GhcPs
hsmod) Maybe (XRec GhcPs ModuleName)
Maybe (LocatedA ModuleName)
hsmodName
R ()
newline
Bool
preserveGroups <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f Bool
forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
[[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]]
normalizeImports Bool
preserveGroups [LImportDecl GhcPs]
hsmodImports) (([GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> R ()) -> R ())
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
importGroup -> do
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
importGroup ((ImportDecl GhcPs -> R ())
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> R ()
forall l a. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' ImportDecl GhcPs -> R ()
p_hsmodImport)
R ()
newline
R ()
declNewline
[SrcSpan] -> R () -> R ()
switchLayout (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
hsmodDecls) (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
Bool
preserveSpacing <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f Bool
forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
(if Bool
preserveSpacing then FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDeclsRespectGrouping else FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls) FamilyStyle
Free [LHsDecl GhcPs]
hsmodDecls
R ()
newline
R ()
spitRemainingComments
p_hsModuleHeader :: HsModule GhcPs -> LocatedA ModuleName -> R ()
HsModule {hsmodExt :: forall p. HsModule p -> XCModule p
hsmodExt = XModulePs {Maybe (LWarningTxt GhcPs)
Maybe (LHsDoc GhcPs)
EpAnn AnnsModule
EpLayout
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodLayout :: XModulePs -> EpLayout
hsmodDeprecMessage :: XModulePs -> Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: EpLayout
hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
..}, [LImportDecl GhcPs]
[LHsDecl GhcPs]
Maybe (XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
hsmodName :: forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodExports :: forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodImports :: forall p. HsModule p -> [LImportDecl p]
hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodName :: Maybe (XRec GhcPs ModuleName)
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodImports :: [LImportDecl GhcPs]
hsmodDecls :: [LHsDecl GhcPs]
..} LocatedA ModuleName
moduleName = do
LocatedA ModuleName -> (ModuleName -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedA ModuleName
moduleName ((ModuleName -> R ()) -> R ()) -> (ModuleName -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \ModuleName
name -> do
HaddockPrintStyle
poHStyle <-
(forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyleModule)
-> R HaddockPrintStyleModule
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f HaddockPrintStyleModule
forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyleModule
poHaddockStyleModule R HaddockPrintStyleModule
-> (HaddockPrintStyleModule -> R HaddockPrintStyle)
-> R HaddockPrintStyle
forall a b. R a -> (a -> R b) -> R b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
HaddockPrintStyleModule
PrintStyleInherit -> (forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle)
-> R HaddockPrintStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f HaddockPrintStyle
forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle
poHaddockStyle
PrintStyleOverride HaddockPrintStyle
style -> HaddockPrintStyle -> R HaddockPrintStyle
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HaddockPrintStyle
style
Maybe (LHsDoc GhcPs) -> (LHsDoc GhcPs -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader (HaddockPrintStyle -> HaddockStyle -> Bool -> LHsDoc GhcPs -> R ()
p_hsDoc' HaddockPrintStyle
poHStyle HaddockStyle
Pipe Bool
True)
ModuleName -> R ()
p_hsmodName ModuleName
name
Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LWarningTxt GhcPs)
Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
hsmodDeprecMessage ((GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ())
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnP (WarningTxt GhcPs)
w -> do
R ()
breakpoint
(WarningTxt GhcPs -> R ())
-> GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()
forall l a. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' WarningTxt GhcPs -> R ()
p_warningTxt GenLocated SrcSpanAnnP (WarningTxt GhcPs)
w
Bool
isRespectful <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f Bool
forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
Bool
isDiffFriendly <- (ImportExportStyle -> ImportExportStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ImportExportStyle
ImportExportDiffFriendly) (ImportExportStyle -> Bool) -> R ImportExportStyle -> R Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle)
-> R ImportExportStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f ImportExportStyle
forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle
poImportExportStyle
let breakpointBeforeExportList :: R ()
breakpointBeforeExportList =
case (Maybe (LWarningTxt GhcPs)
Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
hsmodDeprecMessage, Maybe (XRec GhcPs [LIE GhcPs])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
hsmodExports) of
(Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs)),
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]))
_ | Bool -> Bool
not Bool
isDiffFriendly -> R ()
breakpoint
(Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
Nothing, Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
_) -> R ()
space
(Just GenLocated SrcSpanAnnP (WarningTxt GhcPs)
_, Just GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
exports) | (Bool -> Bool
not (Bool -> Bool) -> (SrcSpan -> Bool) -> SrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Bool
isOneLineSpan) (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
exports) -> R ()
space
(Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs)),
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]))
_ -> R ()
breakpoint
breakpointBeforeWhere :: R ()
breakpointBeforeWhere
| Bool -> Bool
not Bool
isRespectful = R ()
breakpointBeforeExportList
| RealSrcSpan -> RealSrcSpan -> Bool
isOnSameLine RealSrcSpan
moduleKeyword RealSrcSpan
whereKeyword = R ()
space
| Just RealSrcSpan
closeParen <- Maybe RealSrcSpan
exportClosePSpan, RealSrcSpan -> RealSrcSpan -> Bool
isOnSameLine RealSrcSpan
closeParen RealSrcSpan
whereKeyword = R ()
space
| Bool
otherwise = R ()
newline
case Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports of
Maybe (XRec GhcPs [LIE GhcPs])
Nothing -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just XRec GhcPs [LIE GhcPs]
l -> do
R ()
breakpointBeforeExportList
GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> ([GenLocated SrcSpanAnnA (IE GhcPs)] -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l [a] -> ([a] -> R ()) -> R ()
encloseLocated XRec GhcPs [LIE GhcPs]
GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
l (([GenLocated SrcSpanAnnA (IE GhcPs)] -> R ()) -> R ())
-> ([GenLocated SrcSpanAnnA (IE GhcPs)] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \[GenLocated SrcSpanAnnA (IE GhcPs)]
exports -> do
R () -> R ()
inci ([LIE GhcPs] -> R ()
p_hsmodExports [LIE GhcPs]
[GenLocated SrcSpanAnnA (IE GhcPs)]
exports)
R ()
breakpointBeforeWhere
Text -> R ()
txt Text
"where"
R ()
newline
where
(RealSrcSpan
moduleKeyword, RealSrcSpan
whereKeyword) =
case AnnsModule -> [AddEpAnn]
am_main (EpAnn AnnsModule -> AnnsModule
forall ann. EpAnn ann -> ann
anns EpAnn AnnsModule
hsmodAnn) of
[AddEpAnn AnnKeywordId
_ EpaLocation
moduleLoc, AddEpAnn AnnKeywordId
AnnWhere EpaLocation
whereLoc] ->
(EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
moduleLoc, EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
whereLoc)
[AddEpAnn]
anns -> [Char] -> (RealSrcSpan, RealSrcSpan)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (RealSrcSpan, RealSrcSpan))
-> [Char] -> (RealSrcSpan, RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ [Char]
"Module had unexpected annotations: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SDoc -> [Char]
showSDocUnsafe ([AddEpAnn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AddEpAnn]
anns)
exportClosePSpan :: Maybe RealSrcSpan
exportClosePSpan = do
AddEpAnn AnnKeywordId
AnnCloseP EpaLocation
loc <- AnnList -> Maybe AddEpAnn
al_close (AnnList -> Maybe AddEpAnn)
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> AnnList)
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> Maybe AddEpAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnL -> AnnList
forall ann. EpAnn ann -> ann
anns (SrcSpanAnnL -> AnnList)
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpanAnnL)
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> AnnList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpanAnnL
forall l e. GenLocated l e -> l
getLoc (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> Maybe AddEpAnn)
-> Maybe
(GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe AddEpAnn
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (XRec GhcPs [LIE GhcPs])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
hsmodExports
RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just (RealSrcSpan -> Maybe RealSrcSpan)
-> RealSrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
loc
isOnSameLine :: RealSrcSpan -> RealSrcSpan -> Bool
isOnSameLine RealSrcSpan
token1 RealSrcSpan
token2 = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
token1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
token2