{-# 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 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 (RealLocated Comment) ->
[([RealLocated Comment], Pragma)] ->
HsModule ->
R ()
p_hsModule :: Maybe (RealLocated Comment)
-> [([RealLocated Comment], Pragma)] -> HsModule -> R ()
p_hsModule Maybe (RealLocated Comment)
mstackHeader [([RealLocated Comment], Pragma)]
pragmas HsModule {[LHsDecl GhcPs]
[LImportDecl GhcPs]
Maybe (LocatedA ModuleName)
Maybe (LocatedL [LIE GhcPs])
Maybe (LocatedP WarningTxt)
Maybe LHsDocString
EpAnn AnnsModule
LayoutInfo
hsmodAnn :: HsModule -> EpAnn AnnsModule
hsmodLayout :: HsModule -> LayoutInfo
hsmodName :: HsModule -> Maybe (LocatedA ModuleName)
hsmodExports :: HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodImports :: HsModule -> [LImportDecl GhcPs]
hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDeprecMessage :: HsModule -> Maybe (LocatedP WarningTxt)
hsmodHaddockModHeader :: HsModule -> Maybe LHsDocString
hsmodHaddockModHeader :: Maybe LHsDocString
hsmodDeprecMessage :: Maybe (LocatedP WarningTxt)
hsmodDecls :: [LHsDecl GhcPs]
hsmodImports :: [LImportDecl GhcPs]
hsmodExports :: Maybe (LocatedL [LIE GhcPs])
hsmodName :: Maybe (LocatedA ModuleName)
hsmodLayout :: LayoutInfo
hsmodAnn :: EpAnn AnnsModule
..} = do
let deprecSpan :: [SrcSpan]
deprecSpan = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA) Maybe (LocatedP WarningTxt)
hsmodDeprecMessage
exportSpans :: [SrcSpan]
exportSpans = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA) Maybe (LocatedL [LIE GhcPs])
hsmodExports
[SrcSpan] -> R () -> R ()
switchLayout ([SrcSpan]
deprecSpan forall a. Semigroup a => a -> a -> a
<> [SrcSpan]
exportSpans) forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (RealLocated Comment)
mstackHeader 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
[([RealLocated Comment], Pragma)] -> R ()
p_pragmas [([RealLocated Comment], Pragma)]
pragmas
R ()
newline
case Maybe (LocatedA ModuleName)
hsmodName of
Maybe (LocatedA ModuleName)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just LocatedA ModuleName
hsmodName' -> do
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedA ModuleName
hsmodName' forall a b. (a -> b) -> a -> b
$ \ModuleName
name -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LHsDocString
hsmodHaddockModHeader (HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
True)
ModuleName -> R ()
p_hsmodName ModuleName
name
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LocatedP WarningTxt)
hsmodDeprecMessage forall a b. (a -> b) -> a -> b
$ \LocatedP WarningTxt
w -> do
R ()
breakpoint
forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' WarningTxt -> R ()
p_moduleWarning LocatedP WarningTxt
w
R ()
breakIfNotDiffFriendly
Bool
diffFriendly <- forall a. Eq a => a -> a -> Bool
(==) ImportExportStyle
ImportExportDiffFriendly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle
poImportExportStyle
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
diffFriendly Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe (LocatedP WarningTxt)
hsmodDeprecMessage)) R ()
newline
case Maybe (LocatedL [LIE GhcPs])
hsmodExports of
Maybe (LocatedL [LIE GhcPs])
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just LocatedL [LIE GhcPs]
l -> do
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedL [LIE GhcPs]
l forall a b. (a -> b) -> a -> b
$ \[GenLocated SrcSpanAnnA (IE GhcPs)]
exports -> do
R () -> R ()
inci ([LIE GhcPs] -> R ()
p_hsmodExports [GenLocated SrcSpanAnnA (IE GhcPs)]
exports)
R ()
breakIfNotDiffFriendly
Text -> R ()
txt Text
"where"
R ()
newline
R ()
newline
Bool
preserveGroups <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
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) forall a b. (a -> b) -> a -> b
$ \[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
importGroup -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
importGroup (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 (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsDecl GhcPs]
hsmodDecls) forall a b. (a -> b) -> a -> b
$ do
Bool
preserveSpacing <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt 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