{-# 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 (LHsDoc GhcPs)
Maybe (LocatedP (WarningTxt GhcPs))
LayoutInfo GhcPs
EpAnn AnnsModule
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: LayoutInfo GhcPs
hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs))
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodLayout :: XModulePs -> LayoutInfo GhcPs
hsmodDeprecMessage :: XModulePs -> Maybe (LocatedP (WarningTxt GhcPs))
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
..} = XCModule GhcPs
hsmodExt
deprecSpan :: [SrcSpan]
deprecSpan = [SrcSpan]
-> (LocatedP (WarningTxt GhcPs) -> [SrcSpan])
-> Maybe (LocatedP (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])
-> (LocatedP (WarningTxt GhcPs) -> SrcSpan)
-> LocatedP (WarningTxt GhcPs)
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedP (WarningTxt GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA) Maybe (LocatedP (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. GenLocated (SrcSpanAnn' 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. HasSrcSpan 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. GenLocated (SrcSpanAnn' 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 (LHsDoc GhcPs)
Maybe (LocatedP (WarningTxt GhcPs))
LayoutInfo GhcPs
EpAnn AnnsModule
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodLayout :: XModulePs -> LayoutInfo GhcPs
hsmodDeprecMessage :: XModulePs -> Maybe (LocatedP (WarningTxt GhcPs))
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: LayoutInfo GhcPs
hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt 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. HasSrcSpan 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 (LocatedP (WarningTxt GhcPs))
-> (LocatedP (WarningTxt GhcPs) -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LocatedP (WarningTxt GhcPs))
hsmodDeprecMessage ((LocatedP (WarningTxt GhcPs) -> R ()) -> R ())
-> (LocatedP (WarningTxt GhcPs) -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \LocatedP (WarningTxt GhcPs)
w -> do
R ()
breakpoint
(WarningTxt GhcPs -> R ()) -> LocatedP (WarningTxt GhcPs) -> R ()
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' WarningTxt GhcPs -> R ()
p_warningTxt LocatedP (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 (LocatedP (WarningTxt GhcPs))
hsmodDeprecMessage, Maybe (XRec GhcPs [LIE GhcPs])
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
hsmodExports) of
(Maybe (LocatedP (WarningTxt GhcPs)),
Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]))
_ | Bool -> Bool
not Bool
isDiffFriendly -> R ()
breakpoint
(Maybe (LocatedP (WarningTxt GhcPs))
Nothing, Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
_) -> R ()
space
(Just LocatedP (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. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
exports) -> R ()
space
(Maybe (LocatedP (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.
HasSrcSpan 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
. EpAnn AnnList -> AnnList
forall ann. EpAnn ann -> ann
anns (EpAnn AnnList -> AnnList)
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> EpAnn AnnList)
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> AnnList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnL -> EpAnn AnnList
forall a. SrcSpanAnn' a -> a
ann (SrcSpanAnnL -> EpAnn AnnList)
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpanAnnL)
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> EpAnn 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