{-# LANGUAGE LambdaCase #-}
{-# 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.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 {[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
    (LocatedA ModuleName -> R ())
-> Maybe (LocatedA ModuleName) -> R ()
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 (LocatedA ModuleName)
Maybe (XRec GhcPs ModuleName)
hsmodName
    R ()
newline
    respectful <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f Bool
forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
    localModules <- getLocalModules
    importGrouping <- getPrinterOpt poImportGrouping
    forM_ (normalizeImports respectful localModules importGrouping hsmodImports) $ \[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. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' ImportDecl GhcPs -> R ()
p_hsmodImport)
      R ()
newline
    declNewline
    switchLayout (getLocA <$> hsmodDecls) $ do
      preserveSpacing <- getPrinterOpt poRespectful
      (if preserveSpacing then p_hsDeclsRespectGrouping else p_hsDecls) Free hsmodDecls
      newline
      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 (LHsDoc GhcPs)
Maybe (LWarningTxt GhcPs)
EpAnn AnnsModule
EpLayout
hsmodAnn :: XModulePs -> EpAnn AnnsModule
hsmodDeprecMessage :: XModulePs -> Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: XModulePs -> Maybe (LHsDoc GhcPs)
hsmodLayout :: XModulePs -> EpLayout
hsmodAnn :: EpAnn AnnsModule
hsmodLayout :: EpLayout
hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs)
hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)
..}, [LImportDecl GhcPs]
[LHsDecl GhcPs]
Maybe (XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodExports :: forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodImports :: forall p. HsModule p -> [LImportDecl p]
hsmodName :: forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName :: Maybe (XRec GhcPs ModuleName)
hsmodExports :: Maybe (XRec GhcPs [LIE GhcPs])
hsmodImports :: [LImportDecl GhcPs]
hsmodDecls :: [LHsDecl GhcPs]
..} LocatedA ModuleName
moduleName = do
  LocatedA ModuleName -> (ModuleName -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located LocatedA ModuleName
moduleName ((ModuleName -> R ()) -> R ()) -> (ModuleName -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \ModuleName
name -> do
    poHStyle <-
      (forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyleModule)
-> R HaddockPrintStyleModule
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f HaddockPrintStyleModule
forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyleModule
poHaddockStyleModule R HaddockPrintStyleModule
-> (HaddockPrintStyleModule -> R HaddockPrintStyle)
-> R HaddockPrintStyle
forall a b. R a -> (a -> R b) -> R b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        HaddockPrintStyleModule
PrintStyleInherit -> (forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle)
-> R HaddockPrintStyle
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f HaddockPrintStyle
forall (f :: * -> *). PrinterOpts f -> f HaddockPrintStyle
poHaddockStyle
        PrintStyleOverride HaddockPrintStyle
style -> HaddockPrintStyle -> R HaddockPrintStyle
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HaddockPrintStyle
style
    forM_ hsmodHaddockModHeader (p_hsDoc' poHStyle Pipe (With #endNewline))
    p_hsmodName name

  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))
Maybe (LWarningTxt 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
    R ()
breakpoint
    (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

  isRespectful <- (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt PrinterOpts f -> f Bool
forall (f :: * -> *). PrinterOpts f -> f Bool
poRespectful
  isDiffFriendly <- (== ImportExportDiffFriendly) <$> getPrinterOpt poImportExportStyle
  let breakpointBeforeExportList =
        case (Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
Maybe (LWarningTxt GhcPs)
hsmodDeprecMessage, Maybe (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports) of
          (Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs)),
 Maybe
   (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]))
_ | Bool -> Bool
not Bool
isDiffFriendly -> R ()
breakpoint
          (Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
Nothing, Maybe (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
_) -> R ()
space
          (Just GenLocated SrcSpanAnnP (WarningTxt GhcPs)
_, Just GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
exports) | (Bool -> Bool
not (Bool -> Bool) -> (SrcSpan -> Bool) -> SrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Bool
isOneLineSpan) (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
exports) -> R ()
space
          (Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs)),
 Maybe
   (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]))
_ -> R ()
breakpoint
      breakpointBeforeWhere
        | Bool -> Bool
not Bool
isRespectful = R ()
breakpointBeforeExportList
        | EpToken "module" -> EpToken "where" -> Bool
forall {tok :: Symbol} {tok :: Symbol}.
EpToken tok -> EpToken tok -> Bool
isOnSameLine EpToken "module"
am_mod EpToken "where"
am_where Bool -> Bool -> Bool
|| EpToken "signature" -> EpToken "where" -> Bool
forall {tok :: Symbol} {tok :: Symbol}.
EpToken tok -> EpToken tok -> Bool
isOnSameLine EpToken "signature"
am_sig EpToken "where"
am_where = R ()
space
        | Just EpToken ")"
closeParen <- Maybe (EpToken ")")
mCloseParen, EpToken ")" -> EpToken "where" -> Bool
forall {tok :: Symbol} {tok :: Symbol}.
EpToken tok -> EpToken tok -> Bool
isOnSameLine EpToken ")"
closeParen EpToken "where"
am_where = R ()
space
        | Bool
otherwise = R ()
newline

  case 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
      R ()
breakpointBeforeExportList
      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)

  breakpointBeforeWhere
  txt "where"
  newline
  where
    AnnsModule {EpToken "signature"
am_sig :: EpToken "signature"
am_sig :: AnnsModule -> EpToken "signature"
am_sig, EpToken "module"
am_mod :: EpToken "module"
am_mod :: AnnsModule -> EpToken "module"
am_mod, EpToken "where"
am_where :: EpToken "where"
am_where :: AnnsModule -> EpToken "where"
am_where} = EpAnn AnnsModule -> AnnsModule
forall ann. EpAnn ann -> ann
anns EpAnn AnnsModule
hsmodAnn
    mCloseParen :: Maybe (EpToken ")")
mCloseParen = do
      AnnList {al_brackets} <- SrcSpanAnnLI -> AnnList (EpToken "hiding", [EpToken ","])
forall ann. EpAnn ann -> ann
anns (SrcSpanAnnLI -> AnnList (EpToken "hiding", [EpToken ","]))
-> (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> SrcSpanAnnLI)
-> GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> AnnList (EpToken "hiding", [EpToken ","])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> SrcSpanAnnLI
forall l e. GenLocated l e -> l
getLoc (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
 -> AnnList (EpToken "hiding", [EpToken ","]))
-> Maybe
     (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe (AnnList (EpToken "hiding", [EpToken ","]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
Maybe (XRec GhcPs [LIE GhcPs])
hsmodExports
      case al_brackets of
        ListParens EpToken "("
_ EpToken ")"
closeParen -> EpToken ")" -> Maybe (EpToken ")")
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpToken ")"
closeParen
        AnnListBrackets
_ -> String -> Maybe (EpToken ")")
forall a. HasCallStack => String -> a
error String
"Unexpectedly got a different kind of bracket in module export list"
    isOnSameLine :: EpToken tok -> EpToken tok -> Bool
isOnSameLine = ((EpToken tok, EpToken tok) -> Bool)
-> EpToken tok -> EpToken tok -> Bool
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((EpToken tok, EpToken tok) -> Bool)
 -> EpToken tok -> EpToken tok -> Bool)
-> ((EpToken tok, EpToken tok) -> Bool)
-> EpToken tok
-> EpToken tok
-> Bool
forall a b. (a -> b) -> a -> b
$ \case
      (EpTok EpaLocation
token1, EpTok EpaLocation
token2) ->
        let loc1 :: RealSrcSpan
loc1 = EpaLocation -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
token1
            loc2 :: RealSrcSpan
loc2 = EpaLocation -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
epaLocationRealSrcSpan EpaLocation
token2
         in RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
loc1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
loc2
      (EpToken tok, EpToken tok)
_ -> Bool
False