{-# 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.Unit.Module.Name
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 (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 hsmod :: HsModule
hsmod@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
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HsModule -> LocatedA ModuleName -> R ()
p_hsModuleHeader HsModule
hsmod) Maybe (LocatedA 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 -> LocatedA ModuleName -> R ()
p_hsModuleHeader :: HsModule -> LocatedA ModuleName -> R ()
p_hsModuleHeader HsModule {[LHsDecl GhcPs]
[LImportDecl GhcPs]
Maybe (LocatedA ModuleName)
Maybe (LocatedL [LIE GhcPs])
Maybe (LocatedP WarningTxt)
Maybe LHsDocString
EpAnn AnnsModule
LayoutInfo
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
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
..} 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
    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

  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)
hsmodDeprecMessage, Maybe (LocatedL [LIE GhcPs])
hsmodExports) of
          (Maybe (LocatedP WarningTxt),
 Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]))
_ | Bool -> Bool
not Bool
isDiffFriendly -> R ()
breakpoint
          (Maybe (LocatedP WarningTxt)
Nothing, Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
_) -> R ()
space
          (Just LocatedP WarningTxt
_, 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),
 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 (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
      R ()
breakpointBeforeExportList
      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 ()
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 (LocatedL [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