{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}

-- | Rendering of modules.
module Ormolu.Printer.Meat.Module
  ( p_hsModule,
  )
where

import Control.Monad
import Data.Choice (pattern With)
import GHC.Hs hiding (comment)
import GHC.Types.SrcLoc
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 HsModule {[LImportDecl GhcPs]
[LHsDecl GhcPs]
Maybe (XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
XCModule GhcPs
hsmodExt :: XCModule GhcPs
hsmodName :: Maybe (XRec GhcPs ModuleName)
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodImports :: [LImportDecl GhcPs]
hsmodDecls :: [LHsDecl 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]
..} = do
  let XModulePs {Maybe (LWarningTxt GhcPs)
Maybe (LHsDoc GhcPs)
EpAnn AnnsModule
EpLayout
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: EpLayout
hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodLayout :: XModulePs -> EpLayout
hsmodDeprecMessage :: XModulePs -> Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
..} = XCModule GhcPs
hsmodExt
      deprecSpan :: [SrcSpan]
deprecSpan = [SrcSpan]
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> [SrcSpan])
-> Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (SrcSpan -> [SrcSpan]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> [SrcSpan])
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> SrcSpan)
-> GenLocated SrcSpanAnnP (WarningTxt GhcPs)
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA) Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
hsmodDeprecMessage
      exportSpans :: [SrcSpan]
exportSpans = [SrcSpan]
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> [SrcSpan])
-> Maybe
     (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> [SrcSpan]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (SrcSpan -> [SrcSpan]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> [SrcSpan])
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> SrcSpan)
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA) Maybe (XRec GhcPs [LIE GhcPs])
Maybe (GenLocated SrcSpanAnnL [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 LComment -> (LComment -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LComment
mstackHeader ((LComment -> R ()) -> R ()) -> (LComment -> 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
    [([LComment], Pragma)] -> R ()
p_pragmas [([LComment], Pragma)]
pragmas
    R ()
newline
    case Maybe (XRec GhcPs ModuleName)
hsmodName of
      Maybe (XRec GhcPs ModuleName)
Nothing -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just XRec GhcPs ModuleName
hsmodName' -> do
        GenLocated SrcSpanAnnA ModuleName -> (ModuleName -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs ModuleName
GenLocated SrcSpanAnnA ModuleName
hsmodName' ((ModuleName -> R ()) -> R ()) -> (ModuleName -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \ModuleName
name -> do
          Maybe (LHsDoc GhcPs) -> (LHsDoc GhcPs -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LHsDoc GhcPs)
hsmodHaddockModHeader (HaddockStyle -> Choice "endNewline" -> LHsDoc GhcPs -> R ()
p_hsDoc HaddockStyle
Pipe (Label "endNewline" -> Choice "endNewline"
forall (a :: Symbol). Label a -> Choice a
With Label "endNewline"
#endNewline))
          ModuleName -> R ()
p_hsmodName ModuleName
name
        R ()
breakpoint
        Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
hsmodDeprecMessage ((GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ())
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnP (WarningTxt GhcPs)
w -> do
          (WarningTxt GhcPs -> R ())
-> GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()
forall l a. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' WarningTxt GhcPs -> R ()
p_warningTxt GenLocated SrcSpanAnnP (WarningTxt GhcPs)
w
          R ()
breakpoint
        case Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports of
          Maybe (XRec GhcPs [LIE GhcPs])
Nothing -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just XRec GhcPs [LIE GhcPs]
l -> do
            GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> ([GenLocated SrcSpanAnnA (IE GhcPs)] -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l [a] -> ([a] -> R ()) -> R ()
encloseLocated XRec GhcPs [LIE GhcPs]
GenLocated SrcSpanAnnL [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 ()
breakpoint
        Text -> R ()
txt Text
"where"
        R ()
newline
    R ()
newline
    [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_ [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
hsmodImports ((ImportDecl GhcPs -> R ())
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> R ()
forall l a. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' ImportDecl GhcPs -> R ()
p_hsmodImport)
    R ()
newline
    [SrcSpan] -> R () -> R ()
switchLayout (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated 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
      FamilyStyle -> [LHsDecl GhcPs] -> R ()
p_hsDecls FamilyStyle
Free [LHsDecl GhcPs]
hsmodDecls
      R ()
newline
      R ()
spitRemainingComments