{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Printing combinators. The definitions here are presented in such an
-- order so you can just go through the Haddocks and by the end of the file
-- you should have a pretty good idea how to program rendering logic.
module Ormolu.Printer.Combinators
  ( -- * The 'R' monad
    R,
    runR,
    getEnclosingSpan,
    isExtensionEnabled,

    -- * Combinators

    -- ** Basic
    txt,
    atom,
    space,
    newline,
    declNewline,
    inci,
    inciBy,
    inciIf,
    inciByFrac,
    inciHalf,
    askSourceType,
    askFixityOverrides,
    askFixityMap,
    located,
    located',
    switchLayout,
    Layout (..),
    vlayout,
    getLayout,
    breakpoint,
    breakpoint',
    getPrinterOpt,

    -- ** Formatting lists
    sep,
    sepSemi,
    canUseBraces,
    useBraces,
    dontUseBraces,

    -- ** Wrapping
    BracketStyle (..),
    sitcc,
    backticks,
    banana,
    braces,
    brackets,
    parens,
    parensHash,
    pragmaBraces,
    pragma,

    -- ** Literals
    comma,
    commaDel,
    commaDelImportExport,
    equals,
    token'Larrowtail,
    token'Rarrowtail,
    token'darrow,
    token'dcolon,
    token'larrow,
    token'larrowtail,
    token'rarrow,
    token'rarrowtail,
    token'star,
    token'forall,
    token'oparenbar,
    token'cparenbar,
    token'openExpQuote,
    token'closeQuote,
    token'lolly,

    -- ** Stateful markers
    SpanMark (..),
    spanMarkSpan,
    HaddockStyle (..),
    setSpanMark,
    getSpanMark,

    -- ** Placement
    Placement (..),
    placeHanging,
  )
where

import Control.Monad
import Data.List (intersperse)
import Data.Text (Text)
import qualified GHC.Data.Strict as Strict
import GHC.LanguageExtensions.Type
import GHC.Types.SrcLoc
import Ormolu.Config
import Ormolu.Config.Types
import Ormolu.Printer.Comments
import Ormolu.Printer.Internal
import Ormolu.Utils (HasSrcSpan (..))

----------------------------------------------------------------------------
-- Basic

-- | Indent the inner expression if the first argument is 'True'.
inciIf ::
  -- | Whether to indent
  Bool ->
  -- | The expression to indent
  R () ->
  R ()
inciIf :: Bool -> R () -> R ()
inciIf Bool
b R ()
m = if Bool
b then R () -> R ()
inci R ()
m else R ()
m

-- | Enter a 'GenLocated' entity. This combinator handles outputting comments
-- and sets layout (single-line vs multi-line) for the inner computation.
-- Roughly, the rule for using 'located' is that every time there is a
-- 'Located' wrapper, it should be “discharged” with a corresponding
-- 'located' invocation.
located ::
  HasSrcSpan l =>
  -- | Thing to enter
  GenLocated l a ->
  -- | How to render inner value
  (a -> R ()) ->
  R ()
located :: forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located (L l
l' a
a) a -> R ()
f = case forall l. HasSrcSpan l => l -> SrcSpan
loc' l
l' of
  UnhelpfulSpan UnhelpfulSpanReason
_ -> a -> R ()
f a
a
  RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ -> do
    RealSrcSpan -> R ()
spitPrecedingComments RealSrcSpan
l
    RealSrcSpan -> R () -> R ()
withEnclosingSpan RealSrcSpan
l forall a b. (a -> b) -> a -> b
$
      [SrcSpan] -> R () -> R ()
switchLayout [RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l forall a. Maybe a
Strict.Nothing] (a -> R ()
f a
a)
    RealSrcSpan -> R ()
spitFollowingComments RealSrcSpan
l

-- | A version of 'located' with arguments flipped.
located' ::
  HasSrcSpan l =>
  -- | How to render inner value
  (a -> R ()) ->
  -- | Thing to enter
  GenLocated l a ->
  R ()
located' :: forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located

-- | Set layout according to combination of given 'SrcSpan's for a given.
-- Use this only when you need to set layout based on e.g. combined span of
-- several elements when there is no corresponding 'Located' wrapper
-- provided by GHC AST. It is relatively rare that this one is needed.
--
-- Given empty list this function will set layout to single line.
switchLayout ::
  -- | Span that controls layout
  [SrcSpan] ->
  -- | Computation to run with changed layout
  R () ->
  R ()
switchLayout :: [SrcSpan] -> R () -> R ()
switchLayout [SrcSpan]
spans' = Layout -> R () -> R ()
enterLayout ([SrcSpan] -> Layout
spansLayout [SrcSpan]
spans')

-- | Which layout combined spans result in?
spansLayout :: [SrcSpan] -> Layout
spansLayout :: [SrcSpan] -> Layout
spansLayout = \case
  [] -> Layout
SingleLine
  (SrcSpan
x : [SrcSpan]
xs) ->
    if SrcSpan -> Bool
isOneLineSpan (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
x [SrcSpan]
xs)
      then Layout
SingleLine
      else Layout
MultiLine

-- | Insert a space if enclosing layout is single-line, or newline if it's
-- multiline.
--
-- > breakpoint = vlayout space newline
breakpoint :: R ()
breakpoint :: R ()
breakpoint = forall a. R a -> R a -> R a
vlayout R ()
space R ()
newline

-- | Similar to 'breakpoint' but outputs nothing in case of single-line
-- layout.
--
-- > breakpoint' = vlayout (return ()) newline
breakpoint' :: R ()
breakpoint' :: R ()
breakpoint' = forall a. R a -> R a -> R a
vlayout (forall (m :: * -> *) a. Monad m => a -> m a
return ()) R ()
newline

----------------------------------------------------------------------------
-- Formatting lists

-- | Render a collection of elements inserting a separator between them.
sep ::
  -- | Separator
  R () ->
  -- | How to render an element
  (a -> R ()) ->
  -- | Elements to render
  [a] ->
  R ()
sep :: forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
s a -> R ()
f [a]
xs = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall a. a -> [a] -> [a]
intersperse R ()
s (a -> R ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs))

-- | Render a collection of elements layout-sensitively using given printer,
-- inserting semicolons if necessary and respecting 'useBraces' and
-- 'dontUseBraces' combinators.
--
-- > useBraces $ sepSemi txt ["foo", "bar"]
-- >   == vlayout (txt "{ foo; bar }") (txt "foo\nbar")
--
-- > dontUseBraces $ sepSemi txt ["foo", "bar"]
-- >   == vlayout (txt "foo; bar") (txt "foo\nbar")
sepSemi ::
  -- | How to render an element
  (a -> R ()) ->
  -- | Elements to render
  [a] ->
  R ()
sepSemi :: forall a. (a -> R ()) -> [a] -> R ()
sepSemi a -> R ()
f [a]
xs = forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine
  where
    singleLine :: R ()
singleLine = do
      Bool
ub <- R Bool
canUseBraces
      case [a]
xs of
        [] -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ub forall a b. (a -> b) -> a -> b
$ Text -> R ()
txt Text
"{}"
        [a]
xs' ->
          if Bool
ub
            then do
              Text -> R ()
txt Text
"{"
              R ()
space
              forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt Text
";" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space) (R () -> R ()
dontUseBraces forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> R ()
f) [a]
xs'
              R ()
space
              Text -> R ()
txt Text
"}"
            else forall a. R () -> (a -> R ()) -> [a] -> R ()
sep (Text -> R ()
txt Text
";" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space) a -> R ()
f [a]
xs'
    multiLine :: R ()
multiLine =
      forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
newline (R () -> R ()
dontUseBraces forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> R ()
f) [a]
xs

----------------------------------------------------------------------------
-- Wrapping

-- | 'BracketStyle' controlling how closing bracket is rendered.
data BracketStyle
  = -- | Normal
    N
  | -- | Shifted one level
    S
  deriving (BracketStyle -> BracketStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BracketStyle -> BracketStyle -> Bool
$c/= :: BracketStyle -> BracketStyle -> Bool
== :: BracketStyle -> BracketStyle -> Bool
$c== :: BracketStyle -> BracketStyle -> Bool
Eq, Int -> BracketStyle -> ShowS
[BracketStyle] -> ShowS
BracketStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BracketStyle] -> ShowS
$cshowList :: [BracketStyle] -> ShowS
show :: BracketStyle -> String
$cshow :: BracketStyle -> String
showsPrec :: Int -> BracketStyle -> ShowS
$cshowsPrec :: Int -> BracketStyle -> ShowS
Show)

-- | Surround given entity by backticks.
backticks :: R () -> R ()
backticks :: R () -> R ()
backticks R ()
m = do
  Text -> R ()
txt Text
"`"
  R ()
m
  Text -> R ()
txt Text
"`"

-- | Surround given entity by banana brackets (i.e., from arrow notation.)
banana :: BracketStyle -> R () -> R ()
banana :: BracketStyle -> R () -> R ()
banana = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
True R ()
token'oparenbar R ()
token'cparenbar

-- | Surround given entity by curly braces @{@ and  @}@.
braces :: BracketStyle -> R () -> R ()
braces :: BracketStyle -> R () -> R ()
braces = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
False (Text -> R ()
txt Text
"{") (Text -> R ()
txt Text
"}")

-- | Surround given entity by square brackets @[@ and @]@.
brackets :: BracketStyle -> R () -> R ()
brackets :: BracketStyle -> R () -> R ()
brackets = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
False (Text -> R ()
txt Text
"[") (Text -> R ()
txt Text
"]")

-- | Surround given entity by parentheses @(@ and @)@.
parens :: BracketStyle -> R () -> R ()
parens :: BracketStyle -> R () -> R ()
parens = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
False (Text -> R ()
txt Text
"(") (Text -> R ()
txt Text
")")

-- | Surround given entity by @(# @ and @ #)@.
parensHash :: BracketStyle -> R () -> R ()
parensHash :: BracketStyle -> R () -> R ()
parensHash = Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
True (Text -> R ()
txt Text
"(#") (Text -> R ()
txt Text
"#)")

-- | Braces as used for pragmas: @{\-#@ and @#-\}@.
pragmaBraces :: R () -> R ()
pragmaBraces :: R () -> R ()
pragmaBraces R ()
m = R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$ do
  Text -> R ()
txt Text
"{-#"
  R ()
space
  R ()
m
  R ()
breakpoint
  R () -> R ()
inci (Text -> R ()
txt Text
"#-}")

-- | Surround the body with a pragma name and 'pragmaBraces'.
pragma ::
  -- | Pragma text
  Text ->
  -- | Pragma body
  R () ->
  R ()
pragma :: Text -> R () -> R ()
pragma Text
pragmaText R ()
body = R () -> R ()
pragmaBraces forall a b. (a -> b) -> a -> b
$ do
  Text -> R ()
txt Text
pragmaText
  R ()
breakpoint
  R ()
body

-- | A helper for defining wrappers like 'parens' and 'braces'.
brackets_ ::
  -- | Insert breakpoints around brackets
  Bool ->
  -- | Opening bracket
  R () ->
  -- | Closing bracket
  R () ->
  -- | Bracket style
  BracketStyle ->
  -- | Inner expression
  R () ->
  R ()
brackets_ :: Bool -> R () -> R () -> BracketStyle -> R () -> R ()
brackets_ Bool
needBreaks R ()
open R ()
close BracketStyle
style R ()
m = R () -> R ()
sitcc (forall a. R a -> R a -> R a
vlayout R ()
singleLine R ()
multiLine)
  where
    singleLine :: R ()
singleLine = do
      R ()
open
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBreaks R ()
space
      R ()
m
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBreaks R ()
space
      R ()
close
    multiLine :: R ()
multiLine = do
      R ()
open
      CommaStyle
commaStyle <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f CommaStyle
poCommaStyle
      case CommaStyle
commaStyle of
        CommaStyle
Leading ->
          if Bool
needBreaks
            then R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ R ()
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
m
            else Bool -> R () -> R ()
inciIf (BracketStyle
style forall a. Eq a => a -> a -> Bool
== BracketStyle
S) forall a b. (a -> b) -> a -> b
$ R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
m
        CommaStyle
Trailing ->
          if Bool
needBreaks
            then R ()
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R () -> R ()
inci R ()
m
            else R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R () -> R ()
sitcc R ()
m
      R ()
newline
      Bool -> R () -> R ()
inciIf (BracketStyle
style forall a. Eq a => a -> a -> Bool
== BracketStyle
S) R ()
close

----------------------------------------------------------------------------
-- Literals

-- | Print @,@.
comma :: R ()
comma :: R ()
comma = Text -> R ()
txt Text
","

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

-- | Delimiting combination with 'comma' for import-export lists.
-- To be used with `sep`.
commaDelImportExport :: R ()
commaDelImportExport :: R ()
commaDelImportExport =
  forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f ImportExportStyle
poImportExportStyle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ImportExportStyle
ImportExportLeading -> CommaStyle -> R ()
commaDel' CommaStyle
Leading
    ImportExportStyle
ImportExportTrailing -> CommaStyle -> R ()
commaDel' CommaStyle
Trailing
    ImportExportStyle
ImportExportDiffFriendly -> CommaStyle -> R ()
commaDel' CommaStyle
Trailing

commaDel' :: CommaStyle -> R ()
commaDel' :: CommaStyle -> R ()
commaDel' = \case
  CommaStyle
Leading -> R ()
breakpoint' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space
  CommaStyle
Trailing -> R ()
comma forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
breakpoint

-- | Print @=@. Do not use @'txt' "="@.
equals :: R ()
equals :: R ()
equals = Text -> R ()
interferingTxt Text
"="

----------------------------------------------------------------------------
-- Token literals
-- The names of the following literals are from GHC's
-- @compiler/GHC/Parser/Lexer.x@.

-- | Print @⤛@ or @-<<@ as appropriate.
token'Larrowtail :: R ()
token'Larrowtail :: R ()
token'Larrowtail = Text
"⤛" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"-<<"

-- | Print @⤜@ or @>>-@ as appropriate.
token'Rarrowtail :: R ()
token'Rarrowtail :: R ()
token'Rarrowtail = Text
"⤜" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
">>-"

-- | Print @⇒@ or @=>@ as appropriate.
token'darrow :: R ()
token'darrow :: R ()
token'darrow = Text
"⇒" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"=>"

-- | Print @∷@ or @::@ as appropriate.
token'dcolon :: R ()
token'dcolon :: R ()
token'dcolon = Text
"∷" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"::"

-- | Print @←@ or @<-@ as appropriate.
token'larrow :: R ()
token'larrow :: R ()
token'larrow = Text
"←" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"<-"

-- | Print @⤙@ or @-<@ as appropriate.
token'larrowtail :: R ()
token'larrowtail :: R ()
token'larrowtail = Text
"⤙" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"-<"

-- | Print @→@ or @->@ as appropriate.
token'rarrow :: R ()
token'rarrow :: R ()
token'rarrow = Text
"→" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"->"

-- | Print @⤚@ or @>-@ as appropriate.
token'rarrowtail :: R ()
token'rarrowtail :: R ()
token'rarrowtail = Text
"⤚" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
">-"

-- | Print @★@ or @*@ as appropriate.
token'star :: R ()
token'star :: R ()
token'star = Text
"★" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"*"

-- | Print @∀@ or @forall@ as appropriate.
token'forall :: R ()
token'forall :: R ()
token'forall = Text
"∀" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"forall"

-- | Print @⦇@ or @(|@ as appropriate.
token'oparenbar :: R ()
token'oparenbar :: R ()
token'oparenbar = Text
"⦇" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"(|"

-- | Print @⦈@ or @|)@ as appropriate.
token'cparenbar :: R ()
token'cparenbar :: R ()
token'cparenbar = Text
"⦈" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"|)"

-- | Print @⟦@ or @[|@ as appropriate.
token'openExpQuote :: R ()
token'openExpQuote :: R ()
token'openExpQuote = Text
"⟦" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"[|"

-- | Print @⟧@ or @|]@ as appropriate.
token'closeQuote :: R ()
token'closeQuote :: R ()
token'closeQuote = Text
"⟧" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"|]"

-- | Print @⊸@ or @%1 ->@ as appropriate.
token'lolly :: R ()
token'lolly :: R ()
token'lolly = Text
"⊸" Text -> Text -> R ()
`whenUnicodeOtherwise` Text
"%1 ->"

-- | Write the one text or the other depending on whether Unicode is enabled.
whenUnicodeOtherwise :: Text -> Text -> R ()
Text
unicodeText whenUnicodeOtherwise :: Text -> Text -> R ()
`whenUnicodeOtherwise` Text
asciiText = do
  Unicode
unicodePrinterOption <- forall a. (forall (f :: * -> *). PrinterOpts f -> f a) -> R a
getPrinterOpt forall (f :: * -> *). PrinterOpts f -> f Unicode
poUnicode
  Bool
unicodeExtensionIsEnabled <- Extension -> R Bool
isExtensionEnabled Extension
UnicodeSyntax
  Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ case Unicode
unicodePrinterOption of
    Unicode
UnicodeDetect -> if Bool
unicodeExtensionIsEnabled then Text
unicodeText else Text
asciiText
    Unicode
UnicodeAlways -> Text
unicodeText
    Unicode
UnicodeNever -> Text
asciiText

----------------------------------------------------------------------------
-- Placement

-- | Expression placement. This marks the places where expressions that
-- implement handing forms may use them.
data Placement
  = -- | Multi-line layout should cause
    -- insertion of a newline and indentation
    -- bump
    Normal
  | -- | Expressions that have hanging form
    -- should use it and avoid bumping one level
    -- of indentation
    Hanging
  deriving (Placement -> Placement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Placement -> Placement -> Bool
$c/= :: Placement -> Placement -> Bool
== :: Placement -> Placement -> Bool
$c== :: Placement -> Placement -> Bool
Eq, Int -> Placement -> ShowS
[Placement] -> ShowS
Placement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Placement] -> ShowS
$cshowList :: [Placement] -> ShowS
show :: Placement -> String
$cshow :: Placement -> String
showsPrec :: Int -> Placement -> ShowS
$cshowsPrec :: Int -> Placement -> ShowS
Show)

-- | Place a thing that may have a hanging form. This function handles how
-- to separate it from preceding expressions and whether to bump indentation
-- depending on what sort of expression we have.
placeHanging :: Placement -> R () -> R ()
placeHanging :: Placement -> R () -> R ()
placeHanging Placement
placement R ()
m =
  case Placement
placement of
    Placement
Hanging -> do
      R ()
space
      R ()
m
    Placement
Normal -> do
      R ()
breakpoint
      R () -> R ()
inci R ()
m