{-# 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 = [SrcSpan]
-> (LocatedP WarningTxt -> [SrcSpan])
-> Maybe (LocatedP WarningTxt)
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (SrcSpan -> [SrcSpan]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> [SrcSpan])
-> (LocatedP WarningTxt -> SrcSpan)
-> LocatedP WarningTxt
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedP WarningTxt -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA) Maybe (LocatedP WarningTxt)
hsmodDeprecMessage
      exportSpans :: [SrcSpan]
exportSpans = [SrcSpan]
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnList)) [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> [SrcSpan])
-> Maybe
     (GenLocated
        (SrcSpanAnn' (EpAnn AnnList)) [GenLocated SrcSpanAnnA (IE GhcPs)])
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (SrcSpan -> [SrcSpan]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> [SrcSpan])
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnList)) [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> SrcSpan)
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnList)) [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  (SrcSpanAnn' (EpAnn AnnList)) [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA) Maybe (LocatedL [LIE GhcPs])
Maybe
  (GenLocated
     (SrcSpanAnn' (EpAnn AnnList)) [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 (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 (LocatedA ModuleName)
hsmodName of
      Maybe (LocatedA ModuleName)
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just LocatedA ModuleName
hsmodName' -> do
        LocatedA ModuleName -> (ModuleName -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedA 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 (LocatedP WarningTxt)
-> (LocatedP WarningTxt -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LocatedP WarningTxt)
hsmodDeprecMessage ((LocatedP WarningTxt -> R ()) -> R ())
-> (LocatedP WarningTxt -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \LocatedP WarningTxt
w -> do
          R ()
breakpoint
          (WarningTxt -> R ()) -> LocatedP WarningTxt -> R ()
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 (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 (LocatedP WarningTxt) -> Bool
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 -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just LocatedL [LIE GhcPs]
l -> do
            GenLocated
  (SrcSpanAnn' (EpAnn AnnList)) [GenLocated SrcSpanAnnA (IE GhcPs)]
-> ([GenLocated SrcSpanAnnA (IE GhcPs)] -> R ()) -> R ()
forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedL [LIE GhcPs]
GenLocated
  (SrcSpanAnn' (EpAnn AnnList)) [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 ()
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
    [[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 forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
      (if Bool
preserveSpacing then FamilyStyle -> [LHsDecl GhcPs] -> R ()
FamilyStyle -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> R ()
p_hsDeclsRespectGrouping else FamilyStyle -> [LHsDecl GhcPs] -> R ()
FamilyStyle -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> R ()
p_hsDecls) FamilyStyle
Free [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
hsmodDecls
      R ()
newline
      R ()
spitRemainingComments