{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Rendering of modules.
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

-- | Render a module-like entity (either a regular module or a backpack
-- signature).
p_hsModule ::
  -- | Stack header
  Maybe (RealLocated Comment) ->
  -- | Pragmas and the associated comments
  [([RealLocated Comment], Pragma)] ->
  -- | AST to print
  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

        -- This works around an awkward idempotency bug with deprecation messages.
        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