{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Common pretty-printing infrastructure for the Swarm project.
module Swarm.Pretty (
  -- * The 'PrettyPrec' class
  PrettyPrec (..),

  -- * Running pretty-printers
  ppr,
  prettyText,
  prettyTextWidth,
  prettyTextLine,
  prettyString,
  docToText,
  docToTextWidth,
  docToString,

  -- * Pretty-printing utilities
  pparens,
  pparens',
  encloseWithIndent,
  bquote,
  prettyShowLow,
  reportBug,
  BulletList (..),
  prettyBinding,
  prettyEquality,
  Wildcard (..),
) where

import Control.Monad.Free
import Data.Fix (Fix, unFix)
import Data.Text (Text)
import Prettyprinter
import Prettyprinter.Render.String qualified as RS
import Prettyprinter.Render.Text qualified as RT
import Swarm.Util (showLowT)

------------------------------------------------------------
-- PrettyPrec class + utilities

-- | Type class for things that can be pretty-printed, given a
--   precedence level of their context.
class PrettyPrec a where
  prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired

instance PrettyPrec Text where
  prettyPrec :: forall ann. Int -> Text -> Doc ann
prettyPrec Int
_ = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

instance (PrettyPrec (t (Fix t))) => PrettyPrec (Fix t) where
  prettyPrec :: forall ann. Int -> Fix t -> Doc ann
prettyPrec Int
p = Int -> t (Fix t) -> Doc ann
forall ann. Int -> t (Fix t) -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p (t (Fix t) -> Doc ann) -> (Fix t -> t (Fix t)) -> Fix t -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix t -> t (Fix t)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

instance (PrettyPrec (t (Free t v)), PrettyPrec v) => PrettyPrec (Free t v) where
  prettyPrec :: forall ann. Int -> Free t v -> Doc ann
prettyPrec Int
p (Free t (Free t v)
t) = Int -> t (Free t v) -> Doc ann
forall ann. Int -> t (Free t v) -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p t (Free t v)
t
  prettyPrec Int
p (Pure v
v) = Int -> v -> Doc ann
forall ann. Int -> v -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p v
v

-- | Pretty-print a thing, with a context precedence level of zero.
ppr :: (PrettyPrec a) => a -> Doc ann
ppr :: forall a ann. PrettyPrec a => a -> Doc ann
ppr = Int -> a -> Doc ann
forall ann. Int -> a -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0

-- | Render a pretty-printed document as @Text@.
docToText :: Doc a -> Text
docToText :: forall a. Doc a -> Text
docToText = SimpleDocStream a -> Text
forall ann. SimpleDocStream ann -> Text
RT.renderStrict (SimpleDocStream a -> Text)
-> (Doc a -> SimpleDocStream a) -> Doc a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

-- | Render a pretty-printed document as @Text@.
--   This function consumes number of allowed characters in a
--   line before introducing a line break. In other words, it
--   expects the space of the layouter to be supplied.
docToTextWidth :: Doc a -> Int -> Text
docToTextWidth :: forall a. Doc a -> Int -> Text
docToTextWidth Doc a
doc Int
layoutWidth =
  SimpleDocStream a -> Text
forall ann. SimpleDocStream ann -> Text
RT.renderStrict (SimpleDocStream a -> Text) -> SimpleDocStream a -> Text
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
layoutWidth Double
1.0)) Doc a
doc

-- | Pretty-print something and render it as @Text@.
prettyText :: (PrettyPrec a) => a -> Text
prettyText :: forall a. PrettyPrec a => a -> Text
prettyText = Doc Any -> Text
forall a. Doc a -> Text
docToText (Doc Any -> Text) -> (a -> Doc Any) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Pretty-print something and render it as @Text@.
--   This is different than @prettyText@ in the sense that it also
--   consumes number of allowed characters in a line before introducing
--   a line break.
prettyTextWidth :: (PrettyPrec a) => a -> Int -> Text
prettyTextWidth :: forall a. PrettyPrec a => a -> Int -> Text
prettyTextWidth = Doc Any -> Int -> Text
forall a. Doc a -> Int -> Text
docToTextWidth (Doc Any -> Int -> Text) -> (a -> Doc Any) -> a -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Pretty-print something and render it as (preferably) one line @Text@.
prettyTextLine :: (PrettyPrec a) => a -> Text
prettyTextLine :: forall a. PrettyPrec a => a -> Text
prettyTextLine = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
RT.renderStrict (SimpleDocStream Any -> Text)
-> (a -> SimpleDocStream Any) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions PageWidth
Unbounded) (Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann
group (Doc Any -> Doc Any) -> (a -> Doc Any) -> a -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Render a pretty-printed document as a @String@.
docToString :: Doc a -> String
docToString :: forall a. Doc a -> String
docToString = SimpleDocStream a -> String
forall ann. SimpleDocStream ann -> String
RS.renderString (SimpleDocStream a -> String)
-> (Doc a -> SimpleDocStream a) -> Doc a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

-- | Pretty-print something and render it as a @String@.
prettyString :: (PrettyPrec a) => a -> String
prettyString :: forall a. PrettyPrec a => a -> String
prettyString = Doc Any -> String
forall a. Doc a -> String
docToString (Doc Any -> String) -> (a -> Doc Any) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr

-- | Optionally surround a document with parentheses depending on the
--   @Bool@ argument and if it does not fit on line, indent the lines,
--   with the parens on separate lines.
pparens :: Bool -> Doc ann -> Doc ann
pparens :: forall ann. Bool -> Doc ann -> Doc ann
pparens Bool
True = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
2 Doc ann
forall ann. Doc ann
lparen Doc ann
forall ann. Doc ann
rparen
pparens Bool
False = Doc ann -> Doc ann
forall a. a -> a
id

-- | Same as pparens but does not indent the lines. Only encloses
--   the document with parantheses.
pparens' :: Bool -> Doc ann -> Doc ann
pparens' :: forall ann. Bool -> Doc ann -> Doc ann
pparens' Bool
True = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
forall ann. Doc ann
lparen Doc ann
forall ann. Doc ann
rparen
pparens' Bool
False = Doc ann -> Doc ann
forall a. a -> a
id

encloseWithIndent :: Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent :: forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
i Doc ann
l Doc ann
r = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
i (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose (Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line') (Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest (-Int
2) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
forall ann. Doc ann
line' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
r)

-- | Surround a document with backticks.
bquote :: Doc ann -> Doc ann
bquote :: forall ann. Doc ann -> Doc ann
bquote = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
"`" Doc ann
"`"

-- | Turn a 'Show' instance into a @Doc@, lowercasing it in the
--   process.
prettyShowLow :: Show a => a -> Doc ann
prettyShowLow :: forall a ann. Show a => a -> Doc ann
prettyShowLow = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> (a -> Text) -> a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Show a => a -> Text
showLowT

-- | An invitation to report an error as a bug.
reportBug :: Doc ann
reportBug :: forall ann. Doc ann
reportBug = Doc ann
"This should never happen; please report this as a bug: https://github.com/swarm-game/swarm/issues/new"

--------------------------------------------------
-- Bullet lists

data BulletList i = BulletList
  { forall i. BulletList i -> forall ann. Doc ann
bulletListHeader :: forall a. Doc a
  , forall i. BulletList i -> [i]
bulletListItems :: [i]
  }

instance (PrettyPrec i) => PrettyPrec (BulletList i) where
  prettyPrec :: forall ann. Int -> BulletList i -> Doc ann
prettyPrec Int
_ (BulletList forall ann. Doc ann
hdr [i]
items) =
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
forall ann. Doc ann
hdr Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (i -> Doc ann) -> [i] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc ann
"-" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> (i -> Doc ann) -> i -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr) [i]
items

--------------------------------------------------
-- Term- and type-printing utilities: bindings, equalities, wildcards,
-- etc.

prettyBinding :: (PrettyPrec a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding :: forall a b ann. (PrettyPrec a, PrettyPrec b) => (a, b) -> Doc ann
prettyBinding (a
x, b
ty) = a -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr a
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> b -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr b
ty

prettyEquality :: (PrettyPrec a, PrettyPrec b) => (a, Maybe b) -> Doc ann
prettyEquality :: forall a b ann.
(PrettyPrec a, PrettyPrec b) =>
(a, Maybe b) -> Doc ann
prettyEquality (a
x, Maybe b
Nothing) = a -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr a
x
prettyEquality (a
x, Just b
t) = a -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr a
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> b -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr b
t

-- | We can use the 'Wildcard' value to replace unification variables
--   when we don't care about them, e.g. to print out the shape of a
--   type like @(_ -> _) * _@
data Wildcard = Wildcard
  deriving (Wildcard -> Wildcard -> Bool
(Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool) -> Eq Wildcard
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Wildcard -> Wildcard -> Bool
== :: Wildcard -> Wildcard -> Bool
$c/= :: Wildcard -> Wildcard -> Bool
/= :: Wildcard -> Wildcard -> Bool
Eq, Eq Wildcard
Eq Wildcard =>
(Wildcard -> Wildcard -> Ordering)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Bool)
-> (Wildcard -> Wildcard -> Wildcard)
-> (Wildcard -> Wildcard -> Wildcard)
-> Ord Wildcard
Wildcard -> Wildcard -> Bool
Wildcard -> Wildcard -> Ordering
Wildcard -> Wildcard -> Wildcard
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Wildcard -> Wildcard -> Ordering
compare :: Wildcard -> Wildcard -> Ordering
$c< :: Wildcard -> Wildcard -> Bool
< :: Wildcard -> Wildcard -> Bool
$c<= :: Wildcard -> Wildcard -> Bool
<= :: Wildcard -> Wildcard -> Bool
$c> :: Wildcard -> Wildcard -> Bool
> :: Wildcard -> Wildcard -> Bool
$c>= :: Wildcard -> Wildcard -> Bool
>= :: Wildcard -> Wildcard -> Bool
$cmax :: Wildcard -> Wildcard -> Wildcard
max :: Wildcard -> Wildcard -> Wildcard
$cmin :: Wildcard -> Wildcard -> Wildcard
min :: Wildcard -> Wildcard -> Wildcard
Ord, Int -> Wildcard -> ShowS
[Wildcard] -> ShowS
Wildcard -> String
(Int -> Wildcard -> ShowS)
-> (Wildcard -> String) -> ([Wildcard] -> ShowS) -> Show Wildcard
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Wildcard -> ShowS
showsPrec :: Int -> Wildcard -> ShowS
$cshow :: Wildcard -> String
show :: Wildcard -> String
$cshowList :: [Wildcard] -> ShowS
showList :: [Wildcard] -> ShowS
Show)

instance PrettyPrec Wildcard where
  prettyPrec :: forall ann. Int -> Wildcard -> Doc ann
prettyPrec Int
_ Wildcard
_ = Doc ann
"_"