{-# 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]
hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodExports :: forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodExt :: forall p. HsModule p -> XCModule p
hsmodImports :: forall p. HsModule p -> [LImportDecl p]
hsmodName :: forall p. HsModule p -> Maybe (XRec p ModuleName)
..} = do
  let XModulePs {Maybe (LHsDoc GhcPs)
Maybe (LWarningTxt GhcPs)
EpAnn AnnsModule
EpLayout
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: EpLayout
hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodDeprecMessage :: XModulePs -> Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
hsmodLayout :: XModulePs -> EpLayout
..} = 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 SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> [SrcSpan])
-> Maybe
     (GenLocated SrcSpanAnnLI [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 SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> SrcSpan)
-> GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA) Maybe (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
Maybe (XRec GhcPs [LIE 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 GenLocated SrcSpanAnnA ModuleName
XRec GhcPs 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 SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> ([GenLocated SrcSpanAnnA (IE GhcPs)] -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l [a] -> ([a] -> R ()) -> R ()
encloseLocated GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
XRec GhcPs [LIE 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 [GenLocated SrcSpanAnnA (IE GhcPs)]
[LIE 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_ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
[LImportDecl 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
<$> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
[LHsDecl 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