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

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

import Control.Monad
import qualified Data.Text as T
import GHC
import Ormolu.Config (poDiffFriendlyImportExport)
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Utils (RelativePos (..), attachRelativePos)

p_hsmodExports :: [LIE GhcPs] -> R ()
p_hsmodExports :: [LIE GhcPs] -> R ()
p_hsmodExports [] = do
  Text -> R ()
txt Text
"("
  R ()
breakpoint'
  Text -> R ()
txt Text
")"
p_hsmodExports [LIE GhcPs]
xs =
  Bool -> R () -> R ()
parens' Bool
False (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Layout
layout <- R Layout
getLayout
    R ()
-> ((RelativePos, LIE GhcPs) -> R ())
-> [(RelativePos, LIE GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
      R ()
breakpoint
      (\(RelativePos
p, LIE GhcPs
l) -> R () -> R ()
sitcc (LIE GhcPs -> (IE GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LIE GhcPs
l (Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
layout RelativePos
p)))
      ([LIE GhcPs] -> [(RelativePos, LIE GhcPs)]
forall a. [a] -> [(RelativePos, a)]
attachRelativePos [LIE GhcPs]
xs)

p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()
p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()
p_hsmodImport Bool
useQualifiedPost ImportDecl {Bool
Maybe (Bool, Located [LIE GhcPs])
Maybe StringLiteral
Maybe (Located ModuleName)
SourceText
Located ModuleName
XCImportDecl GhcPs
ImportDeclQualifiedStyle
ideclSourceSrc :: forall pass. ImportDecl pass -> SourceText
ideclSource :: forall pass. ImportDecl pass -> Bool
ideclSafe :: forall pass. ImportDecl pass -> Bool
ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclPkgQual :: forall pass. ImportDecl pass -> Maybe StringLiteral
ideclName :: forall pass. ImportDecl pass -> Located ModuleName
ideclImplicit :: forall pass. ImportDecl pass -> Bool
ideclHiding :: forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclExt :: forall pass. ImportDecl pass -> XCImportDecl pass
ideclAs :: forall pass. ImportDecl pass -> Maybe (Located ModuleName)
ideclHiding :: Maybe (Bool, Located [LIE GhcPs])
ideclAs :: Maybe (Located ModuleName)
ideclImplicit :: Bool
ideclQualified :: ImportDeclQualifiedStyle
ideclSafe :: Bool
ideclSource :: Bool
ideclPkgQual :: Maybe StringLiteral
ideclName :: Located ModuleName
ideclSourceSrc :: SourceText
ideclExt :: XCImportDecl GhcPs
..} = do
  Text -> R ()
txt Text
"import"
  R ()
space
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ideclSource (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 Maybe StringLiteral
ideclPkgQual of
    Maybe StringLiteral
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just 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
    Located ModuleName -> (ModuleName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"qualified")
    case Maybe (Located ModuleName)
ideclAs of
      Maybe (Located ModuleName)
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Located ModuleName
l -> do
        R ()
space
        Text -> R ()
txt Text
"as"
        R ()
space
        Located ModuleName -> (ModuleName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located ModuleName
l ModuleName -> R ()
forall a. Outputable a => a -> R ()
atom
    R ()
space
    case Maybe (Bool, Located [LIE GhcPs])
ideclHiding of
      Maybe (Bool, Located [LIE GhcPs])
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (Bool
hiding, Located [LIE GhcPs]
_) ->
        Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hiding (Text -> R ()
txt Text
"hiding")
    case Maybe (Bool, Located [LIE GhcPs])
ideclHiding of
      Maybe (Bool, Located [LIE GhcPs])
Nothing -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (Bool
_, L SrcSpan
_ [LIE GhcPs]
xs) -> do
        R ()
breakIfNotDiffFriendly
        Bool -> R () -> R ()
parens' Bool
True (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
          Layout
layout <- R Layout
getLayout
          R ()
-> ((RelativePos, LIE GhcPs) -> R ())
-> [(RelativePos, LIE GhcPs)]
-> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
            R ()
breakpoint
            (\(RelativePos
p, LIE GhcPs
l) -> R () -> R ()
sitcc (LIE GhcPs -> (IE GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LIE GhcPs
l (Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
layout RelativePos
p)))
            ([LIE GhcPs] -> [(RelativePos, LIE GhcPs)]
forall a. [a] -> [(RelativePos, a)]
attachRelativePos [LIE GhcPs]
xs)
    R ()
newline
p_hsmodImport Bool
_ (XImportDecl XXImportDecl GhcPs
x) = NoExtCon -> R ()
forall a. NoExtCon -> a
noExtCon NoExtCon
XXImportDecl GhcPs
x

p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
p_lie Layout
encLayout RelativePos
relativePos = \case
  IEVar XIEVar GhcPs
NoExtField LIEWrappedName (IdP GhcPs)
l1 -> do
    Located (IEWrappedName RdrName)
-> (IEWrappedName RdrName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (IEWrappedName RdrName)
LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
    R ()
p_comma
  IEThingAbs XIEThingAbs GhcPs
NoExtField LIEWrappedName (IdP GhcPs)
l1 -> do
    Located (IEWrappedName RdrName)
-> (IEWrappedName RdrName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (IEWrappedName RdrName)
LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
    R ()
p_comma
  IEThingAll XIEThingAll GhcPs
NoExtField LIEWrappedName (IdP GhcPs)
l1 -> do
    Located (IEWrappedName RdrName)
-> (IEWrappedName RdrName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (IEWrappedName RdrName)
LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
    R ()
space
    Text -> R ()
txt Text
"(..)"
    R ()
p_comma
  IEThingWith XIEThingWith GhcPs
NoExtField LIEWrappedName (IdP GhcPs)
l1 IEWildcard
w [LIEWrappedName (IdP GhcPs)]
xs [Located (FieldLbl (IdP GhcPs))]
_ -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    Located (IEWrappedName RdrName)
-> (IEWrappedName RdrName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located (IEWrappedName RdrName)
LIEWrappedName (IdP GhcPs)
l1 IEWrappedName RdrName -> R ()
p_ieWrappedName
    R ()
breakIfNotDiffFriendly
    R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      let names :: [R ()]
          names :: [R ()]
names = (IEWrappedName RdrName -> R ())
-> Located (IEWrappedName RdrName) -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' IEWrappedName RdrName -> R ()
p_ieWrappedName (Located (IEWrappedName RdrName) -> R ())
-> [Located (IEWrappedName RdrName)] -> [R ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located (IEWrappedName RdrName)]
[LIEWrappedName (IdP GhcPs)]
xs
      Bool -> R () -> R ()
parens' Bool
False (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
  IEModuleContents XIEModuleContents GhcPs
NoExtField Located ModuleName
l1 -> do
    Located ModuleName -> (ModuleName -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located Located ModuleName
l1 ModuleName -> R ()
p_hsmodName
    R ()
p_comma
  IEGroup XIEGroup GhcPs
NoExtField Int
n HsDocString
str -> do
    case RelativePos
relativePos of
      RelativePos
SinglePos -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RelativePos
FirstPos -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      RelativePos
MiddlePos -> R ()
newline
      RelativePos
LastPos -> R ()
newline
    HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString (Int -> HaddockStyle
Asterisk Int
n) Bool
False (SrcSpanLess LHsDocString -> LHsDocString
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsDocString
SrcSpanLess LHsDocString
str)
  IEDoc XIEDoc GhcPs
NoExtField HsDocString
str ->
    HaddockStyle -> Bool -> LHsDocString -> R ()
p_hsDocString HaddockStyle
Pipe Bool
False (SrcSpanLess LHsDocString -> LHsDocString
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsDocString
SrcSpanLess LHsDocString
str)
  IEDocNamed XIEDocNamed GhcPs
NoExtField String
str -> Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ Text
"-- $" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
str
  XIE XXIE GhcPs
x -> NoExtCon -> R ()
forall a. NoExtCon -> a
noExtCon NoExtCon
XXIE GhcPs
x
  where
    p_comma :: R ()
p_comma =
      case Layout
encLayout of
        Layout
SingleLine ->
          case RelativePos
relativePos of
            RelativePos
SinglePos -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            RelativePos
FirstPos -> R ()
comma
            RelativePos
MiddlePos -> R ()
comma
            RelativePos
LastPos -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Layout
MultiLine -> R ()
comma

----------------------------------------------------------------------------
-- Unlike the versions in 'Ormolu.Printer.Combinators', these do not depend on
-- whether 'leadingCommas' is set. This is useful here is we choose to keep
-- import and export lists independent of that setting.

-- | Delimiting combination with 'comma'. To be used with 'sep'.
commaDel' :: R ()
commaDel' :: R ()
commaDel' = R ()
comma R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint

-- | Surround given entity by parentheses @(@ and @)@.
parens' :: Bool -> R () -> R ()
parens' :: Bool -> R () -> R ()
parens' Bool
topLevelImport R ()
m =
  (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Bool
poDiffFriendlyImportExport R Bool -> (Bool -> R ()) -> R ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> do
      Text -> R ()
txt Text
"("
      R ()
breakpoint'
      R () -> R ()
sitcc R ()
body
      R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout (Text -> R ()
txt Text
")") (Int -> R () -> R ()
inciBy (-Int
1) R ()
trailingParen)
    Bool
False -> R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> R ()
txt Text
"("
      R ()
body
      Text -> R ()
txt Text
")"
  where
    body :: R ()
body = R () -> R () -> R ()
forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine
    singleLine :: R ()
singleLine = R ()
m
    multiLine :: R ()
multiLine = do
      R ()
space
      R () -> R ()
sitcc R ()
m
      R ()
newline
    trailingParen :: R ()
trailingParen = if Bool
topLevelImport then Text -> R ()
txt Text
" )" else Text -> R ()
txt Text
")"

breakIfNotDiffFriendly :: R ()
breakIfNotDiffFriendly :: R ()
breakIfNotDiffFriendly =
  (forall (f :: * -> *). PrinterOpts f -> f Bool) -> R Bool
forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Bool
poDiffFriendlyImportExport R Bool -> (Bool -> R ()) -> R ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> R ()
space
    Bool
False -> R ()
breakpoint