{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Ormolu.Printer.Meat.Module
( p_hsModule,
)
where
import Control.Monad
import GHC.Hs
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 (Located [LIE GhcPs])
Maybe LHsDocString
Maybe (Located WarningTxt)
Maybe (Located ModuleName)
LayoutInfo
hsmodLayout :: HsModule -> LayoutInfo
hsmodName :: HsModule -> Maybe (Located ModuleName)
hsmodExports :: HsModule -> Maybe (Located [LIE GhcPs])
hsmodImports :: HsModule -> [LImportDecl GhcPs]
hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDeprecMessage :: HsModule -> Maybe (Located WarningTxt)
hsmodHaddockModHeader :: HsModule -> Maybe LHsDocString
hsmodHaddockModHeader :: Maybe LHsDocString
hsmodDeprecMessage :: Maybe (Located WarningTxt)
hsmodDecls :: [LHsDecl GhcPs]
hsmodImports :: [LImportDecl GhcPs]
hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodName :: Maybe (Located ModuleName)
hsmodLayout :: LayoutInfo
..} = do
let deprecSpan :: [SrcSpan]
deprecSpan = [SrcSpan]
-> (Located WarningTxt -> [SrcSpan])
-> Maybe (Located WarningTxt)
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(L SrcSpan
s WarningTxt
_) -> [SrcSpan
s]) Maybe (Located WarningTxt)
hsmodDeprecMessage
exportSpans :: [SrcSpan]
exportSpans = [SrcSpan]
-> (Located [LIE GhcPs] -> [SrcSpan])
-> Maybe (Located [LIE GhcPs])
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(L SrcSpan
s [LIE GhcPs]
_) -> [SrcSpan
s]) Maybe (Located [LIE 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 (RealLocated Comment)
-> (RealLocated Comment -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (RealLocated Comment)
mstackHeader ((RealLocated Comment -> R ()) -> R ())
-> (RealLocated Comment -> 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
[([RealLocated Comment], Pragma)] -> R ()
p_pragmas [([RealLocated Comment], Pragma)]
pragmas
R ()
newline
case Maybe (Located ModuleName)
hsmodName of
Maybe (Located ModuleName)
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Located ModuleName
hsmodName' -> do
Located ModuleName -> (ModuleName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located ModuleName
hsmodName' ((ModuleName -> R ()) -> R ()) -> (ModuleName -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \ModuleName
name -> do
Maybe LHsDocString -> (LHsDocString -> R ()) -> R ()
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
Maybe (Located WarningTxt) -> (Located WarningTxt -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Located WarningTxt)
hsmodDeprecMessage ((Located WarningTxt -> R ()) -> R ())
-> (Located WarningTxt -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \Located WarningTxt
w -> do
R ()
breakpoint
(WarningTxt -> R ()) -> Located WarningTxt -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' WarningTxt -> R ()
p_moduleWarning Located WarningTxt
w
R ()
breakIfNotDiffFriendly
Bool
diffFriendly <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Bool
poDiffFriendlyImportExport
Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
diffFriendly Bool -> Bool -> Bool
&& Bool -> Bool
not (Maybe (Located WarningTxt) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe (Located WarningTxt)
hsmodDeprecMessage)) R ()
newline
case Maybe (Located [LIE GhcPs])
hsmodExports of
Maybe (Located [LIE GhcPs])
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Located [LIE GhcPs]
l -> do
Located [LIE GhcPs] -> ([LIE GhcPs] -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located [LIE GhcPs]
l (([LIE GhcPs] -> R ()) -> R ()) -> ([LIE GhcPs] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \[LIE GhcPs]
exports -> do
R () -> R ()
inci ([LIE GhcPs] -> R ()
p_hsmodExports [LIE GhcPs]
exports)
R ()
breakIfNotDiffFriendly
Text -> R ()
txt Text
"where"
R ()
newline
R ()
newline
Bool
preserveGroups <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
[[LImportDecl GhcPs]] -> ([LImportDecl 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) (([LImportDecl GhcPs] -> R ()) -> R ())
-> ([LImportDecl GhcPs] -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \[LImportDecl GhcPs]
importGroup -> do
[LImportDecl GhcPs] -> (LImportDecl GhcPs -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LImportDecl GhcPs]
importGroup ((ImportDecl GhcPs -> R ()) -> LImportDecl GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' ImportDecl GhcPs -> R ()
p_hsmodImport)
R ()
newline
R ()
declNewline
[SrcSpan] -> R () -> R ()
switchLayout (LHsDecl GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LHsDecl GhcPs -> SrcSpan) -> [LHsDecl GhcPs] -> [SrcSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsDecl 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 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