{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | A re-export of the prettyprinting library, along with some
-- convenience functions.
module Futhark.Util.Pretty
  ( -- * Rendering to texts
    prettyTuple,
    prettyTupleLines,
    prettyString,
    prettyStringOneLine,
    prettyText,
    prettyTextOneLine,
    docText,
    docTextForHandle,
    docString,

    -- * Rendering to terminal
    putDoc,
    hPutDoc,
    putDocLn,
    hPutDocLn,

    -- * Building blocks
    module Prettyprinter,
    module Prettyprinter.Symbols.Ascii,
    module Prettyprinter.Render.Terminal,
    apply,
    oneLine,
    annot,
    nestedBlock,
    textwrap,
    shorten,
    commastack,
    commasep,
    semistack,
    stack,
    parensIf,
    ppTuple',
    ppTupleLines',

    -- * Operators
    (</>),
  )
where

import Data.Text (Text)
import Data.Text qualified as T
import Numeric.Half
import Prettyprinter
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bgColor, bgColorDull, bold, color, colorDull, italicized, underlined)
import Prettyprinter.Render.Terminal qualified
import Prettyprinter.Render.Text qualified
import Prettyprinter.Symbols.Ascii
import System.IO (Handle, hIsTerminalDevice, hPutStrLn, stdout)

-- | Print a doc with styling to the given file; stripping colors if
-- the file does not seem to support such things.
hPutDoc :: Handle -> Doc AnsiStyle -> IO ()
hPutDoc :: Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
h Doc AnsiStyle
d = do
  colours <- Handle -> IO Bool
hIsTerminalDevice Handle
h
  if colours
    then Prettyprinter.Render.Terminal.renderIO h (layouter d)
    else Prettyprinter.Render.Text.renderIO h (layouter d)
  where
    layouter :: Doc ann -> SimpleDocStream ann
layouter =
      SimpleDocStream ann -> SimpleDocStream ann
forall ann. SimpleDocStream ann -> SimpleDocStream ann
removeTrailingWhitespace
        (SimpleDocStream ann -> SimpleDocStream ann)
-> (Doc ann -> SimpleDocStream ann)
-> Doc ann
-> SimpleDocStream ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions {layoutPageWidth = Unbounded}

-- | Like 'hPutDoc', but with a final newline.
hPutDocLn :: Handle -> Doc AnsiStyle -> IO ()
hPutDocLn :: Handle -> Doc AnsiStyle -> IO ()
hPutDocLn Handle
h Doc AnsiStyle
d = do
  Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
h Doc AnsiStyle
d
  Handle -> String -> IO ()
hPutStrLn Handle
h String
""

-- | Like 'hPutDoc', but to stdout.
putDoc :: Doc AnsiStyle -> IO ()
putDoc :: Doc AnsiStyle -> IO ()
putDoc = Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stdout

-- | Like 'putDoc', but with a final newline.
putDocLn :: Doc AnsiStyle -> IO ()
putDocLn :: Doc AnsiStyle -> IO ()
putDocLn Doc AnsiStyle
d = do
  Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
d
  String -> IO ()
putStrLn String
""

-- | Produce text suitable for printing on the given handle.  This
-- mostly means stripping any control characters if the handle is not
-- a terminal.
docTextForHandle :: Handle -> Doc AnsiStyle -> IO T.Text
docTextForHandle :: Handle -> Doc AnsiStyle -> IO Text
docTextForHandle Handle
h Doc AnsiStyle
d = do
  colours <- Handle -> IO Bool
hIsTerminalDevice Handle
h
  let sds = SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. SimpleDocStream ann -> SimpleDocStream ann
removeTrailingWhitespace (SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle)
-> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions Doc AnsiStyle
d
  pure $
    if colours
      then Prettyprinter.Render.Terminal.renderStrict sds
      else Prettyprinter.Render.Text.renderStrict sds

-- | Prettyprint a value to a 'String', appropriately wrapped.
prettyString :: (Pretty a) => a -> String
prettyString :: forall a. Pretty a => a -> String
prettyString = Text -> String
T.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Pretty a => a -> Text
prettyText

-- | Prettyprint a value to a 'String' on a single line.
prettyStringOneLine :: (Pretty a) => a -> String
prettyStringOneLine :: forall a. Pretty a => a -> String
prettyStringOneLine = Text -> String
T.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine

-- | Prettyprint a value to a 'Text', appropriately wrapped.
prettyText :: (Pretty a) => a -> Text
prettyText :: forall a. Pretty a => a -> Text
prettyText = Doc (ZonkAny 4) -> Text
forall a. Doc a -> Text
docText (Doc (ZonkAny 4) -> Text) -> (a -> Doc (ZonkAny 4)) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc (ZonkAny 4)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

-- | Convert a 'Doc' to text.  This ignores any annotations (i.e. it
-- will be non-coloured output).
docText :: Doc a -> T.Text
docText :: forall a. Doc a -> Text
docText = SimpleDocStream a -> Text
forall ann. SimpleDocStream ann -> Text
Prettyprinter.Render.Text.renderStrict (SimpleDocStream a -> Text)
-> (Doc a -> SimpleDocStream a) -> Doc a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> SimpleDocStream a
forall {ann}. Doc ann -> SimpleDocStream ann
layouter
  where
    layouter :: Doc ann -> SimpleDocStream ann
layouter =
      SimpleDocStream ann -> SimpleDocStream ann
forall ann. SimpleDocStream ann -> SimpleDocStream ann
removeTrailingWhitespace
        (SimpleDocStream ann -> SimpleDocStream ann)
-> (Doc ann -> SimpleDocStream ann)
-> Doc ann
-> SimpleDocStream ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions {layoutPageWidth = Unbounded}

-- | Convert a 'Doc' to a 'String', through 'docText'. Intended for
-- debugging.
docString :: Doc a -> String
docString :: forall a. Doc a -> String
docString = Text -> String
T.unpack (Text -> String) -> (Doc a -> Text) -> Doc a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> Text
forall a. Doc a -> Text
docText

-- | Prettyprint a value to a 'Text' on a single line.
prettyTextOneLine :: (Pretty a) => a -> Text
prettyTextOneLine :: forall a. Pretty a => a -> Text
prettyTextOneLine = SimpleDocStream (ZonkAny 1) -> Text
forall ann. SimpleDocStream ann -> Text
Prettyprinter.Render.Text.renderStrict (SimpleDocStream (ZonkAny 1) -> Text)
-> (a -> SimpleDocStream (ZonkAny 1)) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc (ZonkAny 1) -> SimpleDocStream (ZonkAny 1)
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
oneLineLayout (Doc (ZonkAny 1) -> SimpleDocStream (ZonkAny 1))
-> (a -> Doc (ZonkAny 1)) -> a -> SimpleDocStream (ZonkAny 1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (ZonkAny 1) -> Doc (ZonkAny 1)
forall ann. Doc ann -> Doc ann
group (Doc (ZonkAny 1) -> Doc (ZonkAny 1))
-> (a -> Doc (ZonkAny 1)) -> a -> Doc (ZonkAny 1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc (ZonkAny 1)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty
  where
    oneLineLayout :: LayoutOptions
oneLineLayout = LayoutOptions
defaultLayoutOptions {layoutPageWidth = Unbounded}

ppTuple' :: [Doc a] -> Doc a
ppTuple' :: forall a. [Doc a] -> Doc a
ppTuple' [Doc a]
ets = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
braces (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
commasep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$ (Doc a -> Doc a) -> [Doc a] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Doc a -> Doc a
forall ann. Doc ann -> Doc ann
align [Doc a]
ets

ppTupleLines' :: [Doc a] -> Doc a
ppTupleLines' :: forall a. [Doc a] -> Doc a
ppTupleLines' [Doc a]
ets = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
braces (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
commastack ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$ (Doc a -> Doc a) -> [Doc a] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Doc a -> Doc a
forall ann. Doc ann -> Doc ann
align [Doc a]
ets

-- | Prettyprint a list enclosed in curly braces.
prettyTuple :: (Pretty a) => [a] -> Text
prettyTuple :: forall a. Pretty a => [a] -> Text
prettyTuple = Doc (ZonkAny 2) -> Text
forall a. Doc a -> Text
docText (Doc (ZonkAny 2) -> Text)
-> ([a] -> Doc (ZonkAny 2)) -> [a] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc (ZonkAny 2)] -> Doc (ZonkAny 2)
forall a. [Doc a] -> Doc a
ppTuple' ([Doc (ZonkAny 2)] -> Doc (ZonkAny 2))
-> ([a] -> [Doc (ZonkAny 2)]) -> [a] -> Doc (ZonkAny 2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc (ZonkAny 2)) -> [a] -> [Doc (ZonkAny 2)]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc (ZonkAny 2)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

-- | Like 'prettyTuple', but put a linebreak after every element.
prettyTupleLines :: (Pretty a) => [a] -> Text
prettyTupleLines :: forall a. Pretty a => [a] -> Text
prettyTupleLines = Doc (ZonkAny 3) -> Text
forall a. Doc a -> Text
docText (Doc (ZonkAny 3) -> Text)
-> ([a] -> Doc (ZonkAny 3)) -> [a] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc (ZonkAny 3)] -> Doc (ZonkAny 3)
forall a. [Doc a] -> Doc a
ppTupleLines' ([Doc (ZonkAny 3)] -> Doc (ZonkAny 3))
-> ([a] -> [Doc (ZonkAny 3)]) -> [a] -> Doc (ZonkAny 3)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc (ZonkAny 3)) -> [a] -> [Doc (ZonkAny 3)]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc (ZonkAny 3)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

-- | The document @'apply' ds@ separates @ds@ with commas and encloses them with
-- parentheses.
apply :: [Doc a] -> Doc a
apply :: forall a. [Doc a] -> Doc a
apply = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
parens (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> Doc a
forall ann. Doc ann -> Doc ann
align (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
commasep ([Doc a] -> Doc a) -> ([Doc a] -> [Doc a]) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc a -> Doc a) -> [Doc a] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Doc a -> Doc a
forall ann. Doc ann -> Doc ann
align

-- | Make sure that the given document is printed on just a single line.
oneLine :: Doc a -> Doc a
oneLine :: forall ann. Doc ann -> Doc ann
oneLine = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
group

-- | Splits the string into words and permits line breaks between all
-- of them.
textwrap :: T.Text -> Doc a
textwrap :: forall a. Text -> Doc a
textwrap = [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
fillSep ([Doc a] -> Doc a) -> (Text -> [Doc a]) -> Text -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc a) -> [Text] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc a
forall a. Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty ([Text] -> [Doc a]) -> (Text -> [Text]) -> Text -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words

-- | Stack and prepend a list of 'Doc's to another 'Doc', separated by
-- a linebreak.  If the list is empty, the second 'Doc' will be
-- returned without a preceding linebreak.
annot :: [Doc a] -> Doc a -> Doc a
annot :: forall a. [Doc a] -> Doc a -> Doc a
annot [] Doc a
s = Doc a
s
annot [Doc a]
l Doc a
s = [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
vsep ([Doc a]
l [Doc a] -> [Doc a] -> [Doc a]
forall a. [a] -> [a] -> [a]
++ [Doc a
s])

-- | Surround the given document with enclosers and add linebreaks and
-- indents.
nestedBlock :: Doc a -> Doc a -> Doc a -> Doc a
nestedBlock :: forall a. Doc a -> Doc a -> Doc a -> Doc a
nestedBlock Doc a
pre Doc a
post Doc a
body = [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
vsep [Doc a
pre, Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc a
body, Doc a
post]

-- | Prettyprint on a single line up to at most some appropriate
-- number of characters, with trailing ... if necessary.  Used for
-- error messages.
shorten :: Doc a -> Doc b
shorten :: forall a b. Doc a -> Doc b
shorten Doc a
a
  | Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
70 = Text -> Doc b
forall a. Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Text -> Text
T.take Int
70 Text
s) Doc b -> Doc b -> Doc b
forall a. Semigroup a => a -> a -> a
<> Doc b
"..."
  | Bool
otherwise = Text -> Doc b
forall a. Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
s
  where
    s :: Text
s = SimpleDocStream (ZonkAny 0) -> Text
forall ann. SimpleDocStream ann -> Text
Prettyprinter.Render.Text.renderStrict (SimpleDocStream (ZonkAny 0) -> Text)
-> SimpleDocStream (ZonkAny 0) -> Text
forall a b. (a -> b) -> a -> b
$ Doc a -> SimpleDocStream (ZonkAny 0)
forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact Doc a
a

-- | Like 'commasep', but a newline after every comma.
commastack :: [Doc a] -> Doc a
commastack :: forall a. [Doc a] -> Doc a
commastack = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
align (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
vsep ([Doc a] -> Doc a) -> ([Doc a] -> [Doc a]) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> [Doc a] -> [Doc a]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc a
forall ann. Doc ann
comma

-- | Separate with semicolons and newlines.
semistack :: [Doc a] -> Doc a
semistack :: forall a. [Doc a] -> Doc a
semistack = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
align (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
vsep ([Doc a] -> Doc a) -> ([Doc a] -> [Doc a]) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> [Doc a] -> [Doc a]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc a
forall ann. Doc ann
semi

-- | Separate with commas.
commasep :: [Doc a] -> Doc a
commasep :: forall a. [Doc a] -> Doc a
commasep = [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
hsep ([Doc a] -> Doc a) -> ([Doc a] -> [Doc a]) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> [Doc a] -> [Doc a]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc a
forall ann. Doc ann
comma

-- | Separate with linebreaks.
stack :: [Doc a] -> Doc a
stack :: forall a. [Doc a] -> Doc a
stack = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
align (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall a. Monoid a => [a] -> a
mconcat ([Doc a] -> Doc a) -> ([Doc a] -> [Doc a]) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> [Doc a] -> [Doc a]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc a
forall ann. Doc ann
line

-- | The document @'parensIf' p d@ encloses the document @d@ in parenthesis if
-- @p@ is @True@, and otherwise yields just @d@.
parensIf :: Bool -> Doc a -> Doc a
parensIf :: forall a. Bool -> Doc a -> Doc a
parensIf Bool
True Doc a
doc = Doc a -> Doc a
forall ann. Doc ann -> Doc ann
parens Doc a
doc
parensIf Bool
False Doc a
doc = Doc a
doc

instance Pretty Half where
  pretty :: forall ann. Half -> Doc ann
pretty = Half -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow

(</>) :: Doc a -> Doc a -> Doc a
Doc a
a </> :: forall a. Doc a -> Doc a -> Doc a
</> Doc a
b = Doc a
a Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall ann. Doc ann
line Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
b