{-# 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 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

-- | Render a module-like entity (either a regular module or a backpack
-- signature).
p_hsModule ::
  -- | Stack header
  Maybe LComment ->
  -- | Pragmas and the associated comments
  [([LComment], Pragma)] ->
  -- | AST to print
  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 {[LHsDecl GhcPs]
[LImportDecl GhcPs]
Maybe (XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
XCModule 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]
hsmodDecls :: [LHsDecl GhcPs]
hsmodImports :: [LImportDecl GhcPs]
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodName :: Maybe (XRec GhcPs ModuleName)
hsmodExt :: XCModule GhcPs
..} = do
  let XModulePs {Maybe (LocatedP (WarningTxt GhcPs))
Maybe (LHsDoc GhcPs)
EpAnn AnnsModule
LayoutInfo GhcPs
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodLayout :: XModulePs -> LayoutInfo GhcPs
hsmodDeprecMessage :: XModulePs -> Maybe (LocatedP (WarningTxt GhcPs))
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs))
hsmodLayout :: LayoutInfo GhcPs
hsmodAnn :: EpAnn AnnsModule
..} = XCModule GhcPs
hsmodExt
      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 GhcPs))
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 (XRec GhcPs [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 LComment
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
    [([LComment], Pragma)] -> R ()
p_pragmas [([LComment], Pragma)]
pragmas
    R ()
newline
    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)
hsmodName
    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

p_hsModuleHeader :: HsModule GhcPs -> LocatedA ModuleName -> R ()
p_hsModuleHeader :: HsModule GhcPs -> LocatedA ModuleName -> R ()
p_hsModuleHeader HsModule {hsmodExt :: forall p. HsModule p -> XCModule p
hsmodExt = XModulePs {Maybe (LocatedP (WarningTxt GhcPs))
Maybe (LHsDoc GhcPs)
EpAnn AnnsModule
LayoutInfo GhcPs
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs))
hsmodLayout :: LayoutInfo GhcPs
hsmodAnn :: EpAnn AnnsModule
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodLayout :: XModulePs -> LayoutInfo GhcPs
hsmodDeprecMessage :: XModulePs -> Maybe (LocatedP (WarningTxt GhcPs))
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
..}, [LHsDecl GhcPs]
[LImportDecl GhcPs]
Maybe (XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
hsmodDecls :: [LHsDecl GhcPs]
hsmodImports :: [LImportDecl GhcPs]
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodName :: 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]
..} LocatedA ModuleName
moduleName = do
  forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedA ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ \ModuleName
name -> do
    HaddockPrintStyle
poHStyle <-
      forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyleModule
poHaddockStyleModule forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        HaddockPrintStyleModule
PrintStyleInherit -> forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle
poHaddockStyle
        PrintStyleOverride HaddockPrintStyle
style -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HaddockPrintStyle
style
    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

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LocatedP (WarningTxt GhcPs))
hsmodDeprecMessage forall a b. (a -> b) -> a -> b
$ \LocatedP (WarningTxt GhcPs)
w -> do
    R ()
breakpoint
    forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' WarningTxt GhcPs -> R ()
p_moduleWarning LocatedP (WarningTxt GhcPs)
w

  Bool
isRespectful <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
  Bool
isDiffFriendly <- (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
  let breakpointBeforeExportList :: R ()
breakpointBeforeExportList =
        case (Maybe (LocatedP (WarningTxt GhcPs))
hsmodDeprecMessage, Maybe (XRec GhcPs [LIE 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Bool
isOneLineSpan) (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just XRec GhcPs [LIE GhcPs]
l -> do
      R ()
breakpointBeforeExportList
      forall l a.
HasSrcSpan l =>
GenLocated l [a] -> ([a] -> R ()) -> R ()
encloseLocated XRec GhcPs [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 ()
breakpointBeforeWhere
  Text -> R ()
txt Text
"where"
  R ()
newline
  where
    (RealSrcSpan
moduleKeyword, RealSrcSpan
whereKeyword) =
      case AnnsModule -> [AddEpAnn]
am_main (forall ann. EpAnn ann -> ann
anns EpAnn AnnsModule
hsmodAnn) of
        -- [AnnModule, AnnWhere] or [AnnSignature, AnnWhere]
        [AddEpAnn AnnKeywordId
_ EpaLocation
moduleLoc, AddEpAnn AnnKeywordId
AnnWhere EpaLocation
whereLoc] ->
          (EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
moduleLoc, EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
whereLoc)
        [AddEpAnn]
anns -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Module had unexpected annotations: " forall a. [a] -> [a] -> [a]
++ SDoc -> [Char]
showSDocUnsafe (forall a. Outputable a => a -> SDoc
ppr [AddEpAnn]
anns)
    exportClosePSpan :: Maybe RealSrcSpan
exportClosePSpan = do
      AddEpAnn AnnKeywordId
AnnCloseP EpaLocation
loc <- AnnList -> Maybe AddEpAnn
al_close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. EpAnn ann -> ann
anns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SrcSpanAnn' a -> a
ann forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports
      forall a. a -> Maybe a
Just 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 forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
token2