{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Rendering of import and export lists.
module Ormolu.Printer.Meat.ImportExport
  ( p_hsmodExports,
    p_hsmodImport,
  )
where

import Control.Monad
import Data.Foldable (for_, traverse_)
import GHC.Hs
import GHC.LanguageExtensions.Type
import GHC.Types.PkgQual
import GHC.Types.SrcLoc
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Declaration.Warning
import Ormolu.Utils (RelativePos (..), attachRelativePos)

p_hsmodExports :: [LIE GhcPs] -> R ()
p_hsmodExports :: [LIE GhcPs] -> R ()
p_hsmodExports [LIE GhcPs]
xs =
  BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Layout
layout <- R Layout
getLayout
    R ()
-> ((RelativePos, GenLocated SrcSpanAnnA (IE GhcPs)) -> R ())
-> [(RelativePos, GenLocated SrcSpanAnnA (IE GhcPs))]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
      R ()
breakpoint
      (\(RelativePos
p, GenLocated SrcSpanAnnA (IE GhcPs)
l) -> R () -> R ()
sitcc (GenLocated SrcSpanAnnA (IE GhcPs) -> (IE GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located (GenLocated SrcSpanAnnA (IE GhcPs)
-> GenLocated SrcSpanAnnA (IE GhcPs)
forall {l}.
(Semigroup l, HasAnnotation l) =>
GenLocated l (IE GhcPs) -> GenLocated l (IE GhcPs)
addDocSrcSpan GenLocated SrcSpanAnnA (IE GhcPs)
l) (Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
layout RelativePos
p)))
      ([GenLocated SrcSpanAnnA (IE GhcPs)]
-> [(RelativePos, GenLocated SrcSpanAnnA (IE GhcPs))]
forall a. [a] -> [(RelativePos, a)]
attachRelativePos [LIE GhcPs]
[GenLocated SrcSpanAnnA (IE GhcPs)]
xs)
  where
    -- In order to correctly set the layout when a doc comment is present.
    addDocSrcSpan :: GenLocated l (IE GhcPs) -> GenLocated l (IE GhcPs)
addDocSrcSpan lie :: GenLocated l (IE GhcPs)
lie@(L l
l IE GhcPs
ie) = case IE GhcPs -> Maybe (ExportDoc GhcPs)
ieExportDoc IE GhcPs
ie of
      Maybe (ExportDoc GhcPs)
Nothing -> GenLocated l (IE GhcPs)
lie
      Just (L SrcSpan
l' HsDoc GhcPs
_) -> l -> IE GhcPs -> GenLocated l (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L (l
l l -> l -> l
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> l
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l') IE GhcPs
ie

p_hsmodImport :: ImportDecl GhcPs -> R ()
p_hsmodImport :: ImportDecl GhcPs -> R ()
p_hsmodImport ImportDecl {Bool
Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
Maybe (XRec GhcPs ModuleName)
ImportDeclPkgQual GhcPs
XCImportDecl GhcPs
XRec GhcPs ModuleName
IsBootInterface
ImportDeclQualifiedStyle
ideclExt :: XCImportDecl GhcPs
ideclName :: XRec GhcPs ModuleName
ideclPkgQual :: ImportDeclPkgQual GhcPs
ideclSource :: IsBootInterface
ideclSafe :: Bool
ideclQualified :: ImportDeclQualifiedStyle
ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclImportList :: Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
ideclExt :: forall pass. ImportDecl pass -> XCImportDecl pass
ideclName :: forall pass. ImportDecl pass -> XRec pass ModuleName
ideclPkgQual :: forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclSource :: forall pass. ImportDecl pass -> IsBootInterface
ideclSafe :: forall pass. ImportDecl pass -> Bool
ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclAs :: forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclImportList :: forall pass.
ImportDecl pass
-> Maybe (ImportListInterpretation, XRec pass [LIE pass])
..} = do
  Bool
useQualifiedPost <- Extension -> R Bool
isExtensionEnabled Extension
ImportQualifiedPost
  Text -> R ()
txt Text
"import"
  R ()
space
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsBootInterface
ideclSource IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (Text -> R ()
txt Text
"{-# SOURCE #-}")
  R ()
space
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ideclSafe (Text -> R ()
txt Text
"safe")
  R ()
space
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (ImportDeclQualifiedStyle -> Bool
isImportDeclQualified ImportDeclQualifiedStyle
ideclQualified Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
useQualifiedPost)
    (Text -> R ()
txt Text
"qualified")
  R ()
space
  case ImportDeclPkgQual GhcPs
ideclPkgQual of
    ImportDeclPkgQual GhcPs
RawPkgQual
NoRawPkgQual -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    RawPkgQual StringLiteral
slit -> StringLiteral -> R ()
forall a. Outputable a => a -> R ()
atom StringLiteral
slit
  R ()
space
  R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ 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
ideclName ModuleName -> R ()
forall a. Outputable a => a -> R ()
atom
    Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (ImportDeclQualifiedStyle -> Bool
isImportDeclQualified ImportDeclQualifiedStyle
ideclQualified Bool -> Bool -> Bool
&& Bool
useQualifiedPost)
      (R ()
space R () -> R () -> R ()
forall a b. R a -> R b -> R b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"qualified")
    case Maybe (XRec GhcPs ModuleName)
ideclAs 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
l -> do
        R ()
space
        Text -> R ()
txt Text
"as"
        R ()
space
        GenLocated SrcSpanAnnA ModuleName -> (ModuleName -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located XRec GhcPs ModuleName
GenLocated SrcSpanAnnA ModuleName
l ModuleName -> R ()
forall a. Outputable a => a -> R ()
atom
    R ()
space
    case Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
ideclImportList of
      Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
Nothing -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (ImportListInterpretation
hiding, L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (IE GhcPs)]
xs) -> do
        case ImportListInterpretation
hiding of
          ImportListInterpretation
Exactly -> () -> R ()
forall a. a -> R a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ImportListInterpretation
EverythingBut -> Text -> R ()
txt Text
"hiding"
        R ()
breakpoint
        BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          Layout
layout <- R Layout
getLayout
          R ()
-> ((RelativePos, GenLocated SrcSpanAnnA (IE GhcPs)) -> R ())
-> [(RelativePos, GenLocated SrcSpanAnnA (IE GhcPs))]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
            R ()
breakpoint
            (\(RelativePos
p, GenLocated SrcSpanAnnA (IE GhcPs)
l) -> R () -> R ()
sitcc (GenLocated SrcSpanAnnA (IE GhcPs) -> (IE GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnA (IE GhcPs)
l (Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
layout RelativePos
p)))
            ([GenLocated SrcSpanAnnA (IE GhcPs)]
-> [(RelativePos, GenLocated SrcSpanAnnA (IE GhcPs))]
forall a. [a] -> [(RelativePos, a)]
attachRelativePos [GenLocated SrcSpanAnnA (IE GhcPs)]
xs)
    R ()
newline

p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
encLayout RelativePos
relativePos = \case
  IEVar XIEVar GhcPs
mwarn LIEWrappedName GhcPs
l1 Maybe (ExportDoc GhcPs)
exportDoc -> do
    Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
XIEVar GhcPs
mwarn ((GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ())
-> (GenLocated SrcSpanAnnP (WarningTxt GhcPs) -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnP (WarningTxt GhcPs)
warnTxt -> do
      GenLocated SrcSpanAnnP (WarningTxt GhcPs)
-> (WarningTxt GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located GenLocated SrcSpanAnnP (WarningTxt GhcPs)
warnTxt WarningTxt GhcPs -> R ()
p_warningTxt
      R ()
breakpoint
    GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
-> (IEWrappedName GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName GhcPs
GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
l1 IEWrappedName GhcPs -> R ()
p_ieWrappedName
    R ()
p_comma
    Maybe (ExportDoc GhcPs) -> R ()
p_exportDoc Maybe (ExportDoc GhcPs)
exportDoc
  IEThingAbs XIEThingAbs GhcPs
_ LIEWrappedName GhcPs
l1 Maybe (ExportDoc GhcPs)
exportDoc -> do
    GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
-> (IEWrappedName GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName GhcPs
GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
l1 IEWrappedName GhcPs -> R ()
p_ieWrappedName
    R ()
p_comma
    Maybe (ExportDoc GhcPs) -> R ()
p_exportDoc Maybe (ExportDoc GhcPs)
exportDoc
  IEThingAll XIEThingAll GhcPs
_ LIEWrappedName GhcPs
l1 Maybe (ExportDoc GhcPs)
exportDoc -> do
    GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
-> (IEWrappedName GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName GhcPs
GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
l1 IEWrappedName GhcPs -> R ()
p_ieWrappedName
    R ()
space
    Text -> R ()
txt Text
"(..)"
    R ()
p_comma
    Maybe (ExportDoc GhcPs) -> R ()
p_exportDoc Maybe (ExportDoc GhcPs)
exportDoc
  IEThingWith XIEThingWith GhcPs
_ LIEWrappedName GhcPs
l1 IEWildcard
w [LIEWrappedName GhcPs]
xs Maybe (ExportDoc GhcPs)
exportDoc -> do
    R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
-> (IEWrappedName GhcPs -> R ()) -> R ()
forall l a. HasLoc l => GenLocated l a -> (a -> R ()) -> R ()
located LIEWrappedName GhcPs
GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
l1 IEWrappedName GhcPs -> R ()
p_ieWrappedName
      R ()
breakpoint
      R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
        let names :: [R ()]
            names :: [R ()]
names = (IEWrappedName GhcPs -> R ())
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs) -> R ()
forall l a. HasLoc l => (a -> R ()) -> GenLocated l a -> R ()
located' IEWrappedName GhcPs -> R ()
p_ieWrappedName (GenLocated SrcSpanAnnA (IEWrappedName GhcPs) -> R ())
-> [GenLocated SrcSpanAnnA (IEWrappedName GhcPs)] -> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LIEWrappedName GhcPs]
[GenLocated SrcSpanAnnA (IEWrappedName GhcPs)]
xs
        BracketStyle -> R () -> R ()
parens BracketStyle
N (R () -> R ()) -> ([R ()] -> R ()) -> [R ()] -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> (R () -> R ()) -> [R ()] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel R () -> R ()
sitcc ([R ()] -> R ()) -> [R ()] -> R ()
forall a b. (a -> b) -> a -> b
$
          case IEWildcard
w of
            IEWildcard
NoIEWildcard -> [R ()]
names
            IEWildcard Int
n ->
              let ([R ()]
before, [R ()]
after) = Int -> [R ()] -> ([R ()], [R ()])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [R ()]
names
               in [R ()]
before [R ()] -> [R ()] -> [R ()]
forall a. [a] -> [a] -> [a]
++ [Text -> R ()
txt Text
".."] [R ()] -> [R ()] -> [R ()]
forall a. [a] -> [a] -> [a]
++ [R ()]
after
      R ()
p_comma
    Maybe (ExportDoc GhcPs) -> R ()
p_exportDoc Maybe (ExportDoc GhcPs)
exportDoc
  IEModuleContents XIEModuleContents GhcPs
_ XRec GhcPs ModuleName
l1 -> 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
l1 ModuleName -> R ()
p_hsmodName
    R ()
p_comma
  IEGroup XIEGroup GhcPs
NoExtField
NoExtField Int
n ExportDoc GhcPs
str -> do
    case RelativePos
relativePos of
      RelativePos
SinglePos -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RelativePos
FirstPos -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RelativePos
MiddlePos -> R ()
newline
      RelativePos
LastPos -> R ()
newline
    HaddockStyle -> Bool -> ExportDoc GhcPs -> R ()
p_hsDoc (Int -> HaddockStyle
Asterisk Int
n) Bool
False ExportDoc GhcPs
str
  IEDoc XIEDoc GhcPs
NoExtField
NoExtField ExportDoc GhcPs
str ->
    HaddockStyle -> Bool -> ExportDoc GhcPs -> R ()
p_hsDoc HaddockStyle
Pipe Bool
False ExportDoc GhcPs
str
  IEDocNamed XIEDocNamed GhcPs
NoExtField
NoExtField String
str -> String -> R ()
p_hsDocName String
str
  where
    p_comma :: R ()
p_comma =
      case Layout
encLayout of
        Layout
SingleLine ->
          case RelativePos
relativePos of
            RelativePos
SinglePos -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            RelativePos
FirstPos -> R ()
comma
            RelativePos
MiddlePos -> R ()
comma
            RelativePos
LastPos -> () -> R ()
forall a. a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Layout
MultiLine -> R ()
comma

    -- This is used to support `@since` annotations for (re)exported items. It
    -- /must/ use caret style comments, see
    -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12098 and
    -- https://github.com/haskell/haddock/issues/1629#issuecomment-1931354411.
    p_exportDoc :: Maybe (ExportDoc GhcPs) -> R ()
    p_exportDoc :: Maybe (ExportDoc GhcPs) -> R ()
p_exportDoc = (ExportDoc GhcPs -> R ()) -> Maybe (ExportDoc GhcPs) -> R ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((ExportDoc GhcPs -> R ()) -> Maybe (ExportDoc GhcPs) -> R ())
-> (ExportDoc GhcPs -> R ()) -> Maybe (ExportDoc GhcPs) -> R ()
forall a b. (a -> b) -> a -> b
$ \ExportDoc GhcPs
exportDoc -> do
      R ()
breakpoint
      HaddockStyle -> Bool -> ExportDoc GhcPs -> R ()
p_hsDoc HaddockStyle
Caret Bool
False ExportDoc GhcPs
exportDoc

ieExportDoc :: IE GhcPs -> Maybe (ExportDoc GhcPs)
ieExportDoc :: IE GhcPs -> Maybe (ExportDoc GhcPs)
ieExportDoc = \case
  IEVar XIEVar GhcPs
_ LIEWrappedName GhcPs
_ Maybe (ExportDoc GhcPs)
doc -> Maybe (ExportDoc GhcPs)
doc
  IEThingAbs XIEThingAbs GhcPs
_ LIEWrappedName GhcPs
_ Maybe (ExportDoc GhcPs)
doc -> Maybe (ExportDoc GhcPs)
doc
  IEThingAll XIEThingAll GhcPs
_ LIEWrappedName GhcPs
_ Maybe (ExportDoc GhcPs)
doc -> Maybe (ExportDoc GhcPs)
doc
  IEThingWith XIEThingWith GhcPs
_ LIEWrappedName GhcPs
_ IEWildcard
_ [LIEWrappedName GhcPs]
_ Maybe (ExportDoc GhcPs)
doc -> Maybe (ExportDoc GhcPs)
doc
  IEModuleContents {} -> Maybe (ExportDoc GhcPs)
forall a. Maybe a
Nothing
  IEGroup {} -> Maybe (ExportDoc GhcPs)
forall a. Maybe a
Nothing
  IEDoc {} -> Maybe (ExportDoc GhcPs)
forall a. Maybe a
Nothing
  IEDocNamed {} -> Maybe (ExportDoc GhcPs)
forall a. Maybe a
Nothing