-- |
-- Pretty printer for Types
--
module Language.PureScript.Pretty.Types
  ( PrettyPrintType(..)
  , PrettyPrintConstraint
  , convertPrettyPrintType
  , typeAsBox
  , typeDiffAsBox
  , prettyPrintType
  , prettyPrintTypeWithUnicode
  , prettyPrintSuggestedType
  , typeAtomAsBox
  , prettyPrintTypeAtom
  , prettyPrintLabel
  , prettyPrintObjectKey
  ) where

import Prelude hiding ((<>))

import Control.Arrow ((<+>))
import Control.PatternArrows as PA

import Data.Bifunctor (first)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Text (Text)
import Data.Text qualified as T

import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (tyFunction, tyRecord)
import Language.PureScript.Names (OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified, coerceProperName, disqualify, showQualified)
import Language.PureScript.Pretty.Common (before, objectKeyRequiresQuoting)
import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), Type(..), WildcardData(..), eqType, rowToSortedList)
import Language.PureScript.PSString (PSString, prettyPrintString, decodeString)
import Language.PureScript.Label (Label(..))

import Text.PrettyPrint.Boxes (Box(..), hcat, hsep, left, moveRight, nullBox, render, text, top, vcat, (<>))

data PrettyPrintType
  = PPTUnknown Int
  | PPTypeVar Text (Maybe Text)
  | PPTypeLevelString PSString
  | PPTypeLevelInt Integer
  | PPTypeWildcard (Maybe Text)
  | PPTypeConstructor (Qualified (ProperName 'TypeName))
  | PPTypeOp (Qualified (OpName 'TypeOpName))
  | PPSkolem Text Int
  | PPTypeApp PrettyPrintType PrettyPrintType
  | PPKindArg PrettyPrintType
  | PPConstrainedType PrettyPrintConstraint PrettyPrintType
  | PPKindedType PrettyPrintType PrettyPrintType
  | PPBinaryNoParensType PrettyPrintType PrettyPrintType PrettyPrintType
  | PPParensInType PrettyPrintType
  | PPForAll [(Text, Maybe PrettyPrintType)] PrettyPrintType
  | PPFunction PrettyPrintType PrettyPrintType
  | PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType)
  | PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType)
  | PPTruncated

type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintType], [PrettyPrintType])

convertPrettyPrintType :: Int -> Type a -> PrettyPrintType
convertPrettyPrintType :: forall a. Int -> Type a -> PrettyPrintType
convertPrettyPrintType = forall {t} {a}. (Ord t, Num t) => t -> Type a -> PrettyPrintType
go
  where
  go :: t -> Type a -> PrettyPrintType
go t
_ (TUnknown a
_ Int
n) = Int -> PrettyPrintType
PPTUnknown Int
n
  go t
_ (TypeVar a
_ Text
t) = Text -> Maybe Text -> PrettyPrintType
PPTypeVar Text
t forall a. Maybe a
Nothing
  go t
_ (TypeLevelString a
_ PSString
s) = PSString -> PrettyPrintType
PPTypeLevelString PSString
s
  go t
_ (TypeLevelInt a
_ Integer
n) = Integer -> PrettyPrintType
PPTypeLevelInt Integer
n
  go t
_ (TypeWildcard a
_ (HoleWildcard Text
n)) = Maybe Text -> PrettyPrintType
PPTypeWildcard (forall a. a -> Maybe a
Just Text
n)
  go t
_ (TypeWildcard a
_ WildcardData
_) = Maybe Text -> PrettyPrintType
PPTypeWildcard forall a. Maybe a
Nothing
  go t
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
c) = Qualified (ProperName 'TypeName) -> PrettyPrintType
PPTypeConstructor Qualified (ProperName 'TypeName)
c
  go t
_ (TypeOp a
_ Qualified (OpName 'TypeOpName)
o) = Qualified (OpName 'TypeOpName) -> PrettyPrintType
PPTypeOp Qualified (OpName 'TypeOpName)
o
  go t
_ (Skolem a
_ Text
t Maybe (Type a)
_ Int
n SkolemScope
_) = Text -> Int -> PrettyPrintType
PPSkolem Text
t Int
n
  go t
_ (REmpty a
_) = [(Label, PrettyPrintType)]
-> Maybe PrettyPrintType -> PrettyPrintType
PPRow [] forall a. Maybe a
Nothing
  -- Guard the remaining "complex" type atoms on the current depth value. The
  -- prior  constructors can all be printed simply so it's not really helpful to
  -- truncate them.
  go t
d Type a
_ | t
d forall a. Ord a => a -> a -> Bool
< t
0 = PrettyPrintType
PPTruncated
  go t
d (ConstrainedType a
_ (Constraint a
_ Qualified (ProperName 'ClassName)
cls [Type a]
kargs [Type a]
args Maybe ConstraintData
_) Type a
ty) = PrettyPrintConstraint -> PrettyPrintType -> PrettyPrintType
PPConstrainedType (Qualified (ProperName 'ClassName)
cls, t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type a]
kargs, t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type a]
args) (t -> Type a -> PrettyPrintType
go t
d Type a
ty)
  go t
d (KindedType a
_ Type a
ty Type a
k) = PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPKindedType (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
ty) (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
k)
  go t
d (BinaryNoParensType a
_ Type a
ty1 Type a
ty2 Type a
ty3) = PrettyPrintType
-> PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPBinaryNoParensType (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
ty1) (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
ty2) (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
ty3)
  go t
d (ParensInType a
_ Type a
ty) = PrettyPrintType -> PrettyPrintType
PPParensInType (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
ty)
  go t
d ty :: Type a
ty@RCons{} = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [(Label, PrettyPrintType)]
-> Maybe PrettyPrintType -> PrettyPrintType
PPRow (t -> Type a -> ([(Label, PrettyPrintType)], Maybe PrettyPrintType)
goRow t
d Type a
ty)
  go t
d (ForAll a
_ Text
v Maybe (Type a)
mbK Type a
ty Maybe SkolemScope
_) = t -> [(Text, Maybe PrettyPrintType)] -> Type a -> PrettyPrintType
goForAll t
d [(Text
v, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1)) Maybe (Type a)
mbK)] Type a
ty
  go t
d (TypeApp a
_ Type a
a Type a
b) = t -> Type a -> Type a -> PrettyPrintType
goTypeApp t
d Type a
a Type a
b
  go t
d (KindApp a
_ Type a
a Type a
b) = PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPTypeApp (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
a) (PrettyPrintType -> PrettyPrintType
PPKindArg (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
b))

  goForAll :: t -> [(Text, Maybe PrettyPrintType)] -> Type a -> PrettyPrintType
goForAll t
d [(Text, Maybe PrettyPrintType)]
vs (ForAll a
_ Text
v Maybe (Type a)
mbK Type a
ty Maybe SkolemScope
_) = t -> [(Text, Maybe PrettyPrintType)] -> Type a -> PrettyPrintType
goForAll t
d ((Text
v, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1)) Maybe (Type a)
mbK) forall a. a -> [a] -> [a]
: [(Text, Maybe PrettyPrintType)]
vs) Type a
ty
  goForAll t
d [(Text, Maybe PrettyPrintType)]
vs Type a
ty = [(Text, Maybe PrettyPrintType)]
-> PrettyPrintType -> PrettyPrintType
PPForAll (forall a. [a] -> [a]
reverse [(Text, Maybe PrettyPrintType)]
vs) (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
ty)

  goRow :: t -> Type a -> ([(Label, PrettyPrintType)], Maybe PrettyPrintType)
goRow t
d Type a
ty =
    let ([RowListItem a]
items, Type a
tail_) = forall a. Type a -> ([RowListItem a], Type a)
rowToSortedList Type a
ty
    in ( forall a b. (a -> b) -> [a] -> [b]
map (\RowListItem a
item -> (forall a. RowListItem a -> Label
rowListLabel RowListItem a
item, t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) (forall a. RowListItem a -> Type a
rowListType RowListItem a
item))) [RowListItem a]
items
       , case Type a
tail_ of
           REmptyKinded a
_ Maybe (Type a)
_ -> forall a. Maybe a
Nothing
           Type a
_ -> forall a. a -> Maybe a
Just (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
tail_)
       )

  goTypeApp :: t -> Type a -> Type a -> PrettyPrintType
goTypeApp t
d (TypeApp a
_ Type a
f Type a
a) Type a
b
    | forall a b. Type a -> Type b -> Bool
eqType Type a
f SourceType
tyFunction = PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPFunction (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
a) (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
b)
    | Bool
otherwise = PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPTypeApp (t -> Type a -> Type a -> PrettyPrintType
goTypeApp t
d Type a
f Type a
a) (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
b)
  goTypeApp t
d Type a
o ty :: Type a
ty@RCons{}
    | forall a b. Type a -> Type b -> Bool
eqType Type a
o SourceType
tyRecord = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [(Label, PrettyPrintType)]
-> Maybe PrettyPrintType -> PrettyPrintType
PPRecord (t -> Type a -> ([(Label, PrettyPrintType)], Maybe PrettyPrintType)
goRow t
d Type a
ty)
  goTypeApp t
d Type a
a Type a
b = PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPTypeApp (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
a) (t -> Type a -> PrettyPrintType
go (t
dforall a. Num a => a -> a -> a
-t
1) Type a
b)

-- TODO(Christoph): get rid of T.unpack s

constraintsAsBox :: TypeRenderOptions -> PrettyPrintConstraint -> Box -> Box
constraintsAsBox :: TypeRenderOptions -> PrettyPrintConstraint -> Box -> Box
constraintsAsBox TypeRenderOptions
tro PrettyPrintConstraint
con Box
ty =
    PrettyPrintConstraint -> Box
constraintAsBox PrettyPrintConstraint
con Box -> Box -> Box
`before` (Box
" " Box -> Box -> Box
<> [Char] -> Box
text [Char]
doubleRightArrow Box -> Box -> Box
<> Box
" " Box -> Box -> Box
<> Box
ty)
  where
    doubleRightArrow :: [Char]
doubleRightArrow = if TypeRenderOptions -> Bool
troUnicode TypeRenderOptions
tro then [Char]
"⇒" else [Char]
"=>"

constraintAsBox :: PrettyPrintConstraint -> Box
constraintAsBox :: PrettyPrintConstraint -> Box
constraintAsBox (Qualified (ProperName 'ClassName)
pn, [PrettyPrintType]
ks, [PrettyPrintType]
tys) = PrettyPrintType -> Box
typeAsBox' (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPTypeApp (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\PrettyPrintType
a PrettyPrintType
b -> PrettyPrintType -> PrettyPrintType -> PrettyPrintType
PPTypeApp PrettyPrintType
a (PrettyPrintType -> PrettyPrintType
PPKindArg PrettyPrintType
b)) (Qualified (ProperName 'TypeName) -> PrettyPrintType
PPTypeConstructor (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName Qualified (ProperName 'ClassName)
pn)) [PrettyPrintType]
ks) [PrettyPrintType]
tys)

-- |
-- Generate a pretty-printed string representing a Row
--
prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> Box
prettyPrintRowWith :: TypeRenderOptions
-> Char
-> Char
-> [(Label, PrettyPrintType)]
-> Maybe PrettyPrintType
-> Box
prettyPrintRowWith TypeRenderOptions
tro Char
open Char
close [(Label, PrettyPrintType)]
labels Maybe PrettyPrintType
rest =
  case ([(Label, PrettyPrintType)]
labels, Maybe PrettyPrintType
rest) of
    ([], Maybe PrettyPrintType
Nothing) ->
      if TypeRenderOptions -> Bool
troRowAsDiff TypeRenderOptions
tro then [Char] -> Box
text [ Char
open, Char
' ' ] Box -> Box -> Box
<> [Char] -> Box
text [Char]
"..." Box -> Box -> Box
<> [Char] -> Box
text [ Char
' ', Char
close ] else [Char] -> Box
text [ Char
open, Char
close ]
    ([], Just PrettyPrintType
_) ->
      [Char] -> Box
text [ Char
open, Char
' ' ] Box -> Box -> Box
<> Maybe PrettyPrintType -> Box
tailToPs Maybe PrettyPrintType
rest Box -> Box -> Box
<> [Char] -> Box
text [ Char
' ', Char
close ]
    ([(Label, PrettyPrintType)], Maybe PrettyPrintType)
_ ->
      forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
vcat Alignment
left forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Label
nm, PrettyPrintType
ty) Int
i -> Char -> Label -> PrettyPrintType -> Box
nameAndTypeToPs (if Int
i forall a. Eq a => a -> a -> Bool
== Int
0 then Char
open else Char
',') Label
nm PrettyPrintType
ty) [(Label, PrettyPrintType)]
labels [Int
0 :: Int ..] forall a. [a] -> [a] -> [a]
++
        forall a. [Maybe a] -> [a]
catMaybes [ Maybe Box
rowDiff, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe PrettyPrintType -> Box
tailToPs Maybe PrettyPrintType
rest, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text [Char
close] ]

  where
  nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box
  nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box
nameAndTypeToPs Char
start Label
name PrettyPrintType
ty = [Char] -> Box
text (Char
start forall a. a -> [a] -> [a]
: Char
' ' forall a. a -> [a] -> [a]
: Text -> [Char]
T.unpack (Label -> Text
prettyPrintLabel Label
name) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
doubleColon forall a. [a] -> [a] -> [a]
++ [Char]
" ") Box -> Box -> Box
<> PrettyPrintType -> Box
typeAsBox' PrettyPrintType
ty

  doubleColon :: [Char]
doubleColon = if TypeRenderOptions -> Bool
troUnicode TypeRenderOptions
tro then [Char]
"∷" else [Char]
"::"

  rowDiff :: Maybe Box
rowDiff = if TypeRenderOptions -> Bool
troRowAsDiff TypeRenderOptions
tro then forall a. a -> Maybe a
Just ([Char] -> Box
text [Char]
"...") else forall a. Maybe a
Nothing

  tailToPs :: Maybe PrettyPrintType -> Box
  tailToPs :: Maybe PrettyPrintType -> Box
tailToPs Maybe PrettyPrintType
Nothing = Box
nullBox
  tailToPs (Just PrettyPrintType
other) = [Char] -> Box
text [Char]
"| " Box -> Box -> Box
<> PrettyPrintType -> Box
typeAsBox' PrettyPrintType
other

typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
typeApp = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType -> Maybe (PrettyPrintType, PrettyPrintType)
match
  where
  match :: PrettyPrintType -> Maybe (PrettyPrintType, PrettyPrintType)
match (PPTypeApp PrettyPrintType
f PrettyPrintType
x) = forall a. a -> Maybe a
Just (PrettyPrintType
f, PrettyPrintType
x)
  match PrettyPrintType
_ = forall a. Maybe a
Nothing

kindArg :: Pattern () PrettyPrintType ((), PrettyPrintType)
kindArg :: Pattern () PrettyPrintType ((), PrettyPrintType)
kindArg = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType -> Maybe ((), PrettyPrintType)
match
  where
  match :: PrettyPrintType -> Maybe ((), PrettyPrintType)
match (PPKindArg PrettyPrintType
ty) = forall a. a -> Maybe a
Just ((), PrettyPrintType
ty)
  match PrettyPrintType
_ = forall a. Maybe a
Nothing

appliedFunction :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
appliedFunction :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
appliedFunction = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType -> Maybe (PrettyPrintType, PrettyPrintType)
match
  where
  match :: PrettyPrintType -> Maybe (PrettyPrintType, PrettyPrintType)
match (PPFunction PrettyPrintType
arg PrettyPrintType
ret) = forall a. a -> Maybe a
Just (PrettyPrintType
arg, PrettyPrintType
ret)
  match PrettyPrintType
_ = forall a. Maybe a
Nothing

kinded :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
kinded :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
kinded = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType -> Maybe (PrettyPrintType, PrettyPrintType)
match
  where
  match :: PrettyPrintType -> Maybe (PrettyPrintType, PrettyPrintType)
match (PPKindedType PrettyPrintType
t PrettyPrintType
k) = forall a. a -> Maybe a
Just (PrettyPrintType
t, PrettyPrintType
k)
  match PrettyPrintType
_ = forall a. Maybe a
Nothing

constrained :: Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType)
constrained :: Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType)
constrained = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType -> Maybe (PrettyPrintConstraint, PrettyPrintType)
match
  where
  match :: PrettyPrintType -> Maybe (PrettyPrintConstraint, PrettyPrintType)
match (PPConstrainedType PrettyPrintConstraint
deps PrettyPrintType
ty) = forall a. a -> Maybe a
Just (PrettyPrintConstraint
deps, PrettyPrintType
ty)
  match PrettyPrintType
_ = forall a. Maybe a
Nothing

explicitParens :: Pattern () PrettyPrintType ((), PrettyPrintType)
explicitParens :: Pattern () PrettyPrintType ((), PrettyPrintType)
explicitParens = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType -> Maybe ((), PrettyPrintType)
match
  where
  match :: PrettyPrintType -> Maybe ((), PrettyPrintType)
match (PPParensInType PrettyPrintType
ty) = forall a. a -> Maybe a
Just ((), PrettyPrintType
ty)
  match PrettyPrintType
_ = forall a. Maybe a
Nothing

matchTypeAtom :: TypeRenderOptions -> Pattern () PrettyPrintType Box
matchTypeAtom :: TypeRenderOptions -> Pattern () PrettyPrintType Box
matchTypeAtom tro :: TypeRenderOptions
tro@TypeRenderOptions{troSuggesting :: TypeRenderOptions -> Bool
troSuggesting = Bool
suggesting} =
    Pattern () PrettyPrintType Box
typeLiterals forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Box -> Box -> Box
`before` [Char] -> Box
text [Char]
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Box
text [Char]
"(" Box -> Box -> Box
<>)) (TypeRenderOptions -> Pattern () PrettyPrintType Box
matchType TypeRenderOptions
tro)
  where
    typeLiterals :: Pattern () PrettyPrintType Box
    typeLiterals :: Pattern () PrettyPrintType Box
typeLiterals = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType -> Maybe Box
match where
      match :: PrettyPrintType -> Maybe Box
match (PPTypeWildcard Maybe Text
name) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"_" ((Char
'?' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) Maybe Text
name
      match (PPTypeVar Text
var Maybe Text
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
var
      match (PPTypeLevelString PSString
s) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ PSString -> Text
prettyPrintString PSString
s
      match (PPTypeLevelInt Integer
n) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Integer
n
      match (PPTypeConstructor Qualified (ProperName 'TypeName)
ctor) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall (a :: ProperNameType). ProperName a -> Text
runProperName forall a b. (a -> b) -> a -> b
$ forall a. Qualified a -> a
disqualify Qualified (ProperName 'TypeName)
ctor
      match (PPTUnknown Int
u)
        | Bool
suggesting = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text [Char]
"_"
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ Char
't' forall a. a -> [a] -> [a]
: forall a. Show a => a -> [Char]
show Int
u
      match (PPSkolem Text
name Int
s)
        | Bool
suggesting =  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
name
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
name forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
s
      match (PPRecord [(Label, PrettyPrintType)]
labels Maybe PrettyPrintType
tail_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TypeRenderOptions
-> Char
-> Char
-> [(Label, PrettyPrintType)]
-> Maybe PrettyPrintType
-> Box
prettyPrintRowWith TypeRenderOptions
tro Char
'{' Char
'}' [(Label, PrettyPrintType)]
labels Maybe PrettyPrintType
tail_
      match (PPRow [(Label, PrettyPrintType)]
labels Maybe PrettyPrintType
tail_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TypeRenderOptions
-> Char
-> Char
-> [(Label, PrettyPrintType)]
-> Maybe PrettyPrintType
-> Box
prettyPrintRowWith TypeRenderOptions
tro Char
'(' Char
')' [(Label, PrettyPrintType)]
labels Maybe PrettyPrintType
tail_
      match (PPBinaryNoParensType PrettyPrintType
op PrettyPrintType
l PrettyPrintType
r) =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PrettyPrintType -> Box
typeAsBox' PrettyPrintType
l Box -> Box -> Box
<> [Char] -> Box
text [Char]
" " Box -> Box -> Box
<> PrettyPrintType -> Box
typeAsBox' PrettyPrintType
op Box -> Box -> Box
<> [Char] -> Box
text [Char]
" " Box -> Box -> Box
<> PrettyPrintType -> Box
typeAsBox' PrettyPrintType
r
      match (PPTypeOp Qualified (OpName 'TypeOpName)
op) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: OpNameType). OpName a -> Text
runOpName Qualified (OpName 'TypeOpName)
op
      match PrettyPrintType
PPTruncated = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> Box
text [Char]
"..."
      match PrettyPrintType
_ = forall a. Maybe a
Nothing

matchType :: TypeRenderOptions -> Pattern () PrettyPrintType Box
matchType :: TypeRenderOptions -> Pattern () PrettyPrintType Box
matchType TypeRenderOptions
tro = forall u a r. OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter OperatorTable () PrettyPrintType Box
operators (TypeRenderOptions -> Pattern () PrettyPrintType Box
matchTypeAtom TypeRenderOptions
tro) where
  operators :: OperatorTable () PrettyPrintType Box
  operators :: OperatorTable () PrettyPrintType Box
operators =
    forall u a r. [[Operator u a r]] -> OperatorTable u a r
OperatorTable [ [ forall u a s r.
Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
Wrap Pattern () PrettyPrintType ((), PrettyPrintType)
kindArg forall a b. (a -> b) -> a -> b
$ \()
_ Box
ty -> [Char] -> Box
text [Char]
"@" Box -> Box -> Box
<> Box
ty ]
                  , [ forall u a r. Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
AssocL Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
typeApp forall a b. (a -> b) -> a -> b
$ \Box
f Box
x -> (Box -> Box) -> Box -> Box -> Box
keepSingleLinesOr (Int -> Box -> Box
moveRight Int
2) Box
f Box
x ]
                  , [ forall u a r. Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
AssocR Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
appliedFunction forall a b. (a -> b) -> a -> b
$ \Box
arg Box
ret -> (Box -> Box) -> Box -> Box -> Box
keepSingleLinesOr forall a. a -> a
id Box
arg ([Char] -> Box
text [Char]
rightArrow Box -> Box -> Box
<> Box
" " Box -> Box -> Box
<> Box
ret) ]
                  , [ forall u a s r.
Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
Wrap Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType)
constrained forall a b. (a -> b) -> a -> b
$ \PrettyPrintConstraint
deps Box
ty -> TypeRenderOptions -> PrettyPrintConstraint -> Box -> Box
constraintsAsBox TypeRenderOptions
tro PrettyPrintConstraint
deps Box
ty ]
                  , [ forall u a s r.
Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
Wrap Pattern
  ()
  PrettyPrintType
  ([([Char], Maybe PrettyPrintType)], PrettyPrintType)
forall_ forall a b. (a -> b) -> a -> b
$ \[([Char], Maybe PrettyPrintType)]
idents Box
ty -> (Box -> Box) -> Box -> Box -> Box
keepSingleLinesOr (Int -> Box -> Box
moveRight Int
2) (forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
hsep Int
1 Alignment
top ([Char] -> Box
text [Char]
forall' forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], Maybe PrettyPrintType) -> Box
printMbKindedType [([Char], Maybe PrettyPrintType)]
idents) Box -> Box -> Box
<> [Char] -> Box
text [Char]
".") Box
ty ]
                  , [ forall u a s r.
Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
Wrap Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)
kinded forall a b. (a -> b) -> a -> b
$ \PrettyPrintType
ty Box
k -> (Box -> Box) -> Box -> Box -> Box
keepSingleLinesOr (Int -> Box -> Box
moveRight Int
2) (PrettyPrintType -> Box
typeAsBox' PrettyPrintType
ty) ([Char] -> Box
text ([Char]
doubleColon forall a. [a] -> [a] -> [a]
++ [Char]
" ") Box -> Box -> Box
<> Box
k) ]
                  , [ forall u a s r.
Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
Wrap Pattern () PrettyPrintType ((), PrettyPrintType)
explicitParens forall a b. (a -> b) -> a -> b
$ \()
_ Box
ty -> Box
ty ]
                  ]

  rightArrow :: [Char]
rightArrow = if TypeRenderOptions -> Bool
troUnicode TypeRenderOptions
tro then [Char]
"→" else [Char]
"->"
  forall' :: [Char]
forall' = if TypeRenderOptions -> Bool
troUnicode TypeRenderOptions
tro then [Char]
"∀" else [Char]
"forall"
  doubleColon :: [Char]
doubleColon = if TypeRenderOptions -> Bool
troUnicode TypeRenderOptions
tro then [Char]
"∷" else [Char]
"::"

  printMbKindedType :: ([Char], Maybe PrettyPrintType) -> Box
printMbKindedType ([Char]
v, Maybe PrettyPrintType
Nothing) = [Char] -> Box
text [Char]
v
  printMbKindedType ([Char]
v, Just PrettyPrintType
k) = [Char] -> Box
text ([Char]
"(" forall a. [a] -> [a] -> [a]
++ [Char]
v forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
doubleColon forall a. [a] -> [a] -> [a]
++ [Char]
" ") Box -> Box -> Box
<> PrettyPrintType -> Box
typeAsBox' PrettyPrintType
k Box -> Box -> Box
<> [Char] -> Box
text [Char]
")"

  -- If both boxes span a single line, keep them on the same line, or else
  -- use the specified function to modify the second box, then combine vertically.
  keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box
  keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box
keepSingleLinesOr Box -> Box
f Box
b1 Box
b2
    | Box -> Int
rows Box
b1 forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Box -> Int
rows Box
b2 forall a. Ord a => a -> a -> Bool
> Int
1 = forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
vcat Alignment
left [ Box
b1, Box -> Box
f Box
b2 ]
    | Bool
otherwise = forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
hcat Alignment
top [ Box
b1, [Char] -> Box
text [Char]
" ", Box
b2]

forall_ :: Pattern () PrettyPrintType ([(String, Maybe PrettyPrintType)], PrettyPrintType)
forall_ :: Pattern
  ()
  PrettyPrintType
  ([([Char], Maybe PrettyPrintType)], PrettyPrintType)
forall_ = forall a b u. (a -> Maybe b) -> Pattern u a b
mkPattern PrettyPrintType
-> Maybe ([([Char], Maybe PrettyPrintType)], PrettyPrintType)
match
  where
  match :: PrettyPrintType
-> Maybe ([([Char], Maybe PrettyPrintType)], PrettyPrintType)
match (PPForAll [(Text, Maybe PrettyPrintType)]
idents PrettyPrintType
ty) = forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Char]
T.unpack) [(Text, Maybe PrettyPrintType)]
idents, PrettyPrintType
ty)
  match PrettyPrintType
_ = forall a. Maybe a
Nothing

typeAtomAsBox' :: PrettyPrintType -> Box
typeAtomAsBox' :: PrettyPrintType -> Box
typeAtomAsBox'
  = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
internalError [Char]
"Incomplete pattern")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall u a b. Pattern u a b -> u -> a -> Maybe b
PA.pattern (TypeRenderOptions -> Pattern () PrettyPrintType Box
matchTypeAtom TypeRenderOptions
defaultOptions) ()

typeAtomAsBox :: Int -> Type a -> Box
typeAtomAsBox :: forall a. Int -> Type a -> Box
typeAtomAsBox Int
maxDepth = PrettyPrintType -> Box
typeAtomAsBox' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Type a -> PrettyPrintType
convertPrettyPrintType Int
maxDepth

-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
prettyPrintTypeAtom :: Int -> Type a -> String
prettyPrintTypeAtom :: forall a. Int -> Type a -> [Char]
prettyPrintTypeAtom Int
maxDepth = Box -> [Char]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Type a -> Box
typeAtomAsBox Int
maxDepth

typeAsBox' :: PrettyPrintType -> Box
typeAsBox' :: PrettyPrintType -> Box
typeAsBox' = TypeRenderOptions -> PrettyPrintType -> Box
typeAsBoxImpl TypeRenderOptions
defaultOptions

typeAsBox :: Int -> Type a -> Box
typeAsBox :: forall a. Int -> Type a -> Box
typeAsBox Int
maxDepth = PrettyPrintType -> Box
typeAsBox' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Type a -> PrettyPrintType
convertPrettyPrintType Int
maxDepth

typeDiffAsBox' :: PrettyPrintType -> Box
typeDiffAsBox' :: PrettyPrintType -> Box
typeDiffAsBox' = TypeRenderOptions -> PrettyPrintType -> Box
typeAsBoxImpl TypeRenderOptions
diffOptions

typeDiffAsBox :: Int -> Type a -> Box
typeDiffAsBox :: forall a. Int -> Type a -> Box
typeDiffAsBox Int
maxDepth = PrettyPrintType -> Box
typeDiffAsBox' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Type a -> PrettyPrintType
convertPrettyPrintType Int
maxDepth

data TypeRenderOptions = TypeRenderOptions
  { TypeRenderOptions -> Bool
troSuggesting :: Bool
  , TypeRenderOptions -> Bool
troUnicode :: Bool
  , TypeRenderOptions -> Bool
troRowAsDiff :: Bool
  }

suggestingOptions :: TypeRenderOptions
suggestingOptions :: TypeRenderOptions
suggestingOptions = Bool -> Bool -> Bool -> TypeRenderOptions
TypeRenderOptions Bool
True Bool
False Bool
False

defaultOptions :: TypeRenderOptions
defaultOptions :: TypeRenderOptions
defaultOptions = Bool -> Bool -> Bool -> TypeRenderOptions
TypeRenderOptions Bool
False Bool
False Bool
False

diffOptions :: TypeRenderOptions
diffOptions :: TypeRenderOptions
diffOptions = Bool -> Bool -> Bool -> TypeRenderOptions
TypeRenderOptions Bool
False Bool
False Bool
True

unicodeOptions :: TypeRenderOptions
unicodeOptions :: TypeRenderOptions
unicodeOptions = Bool -> Bool -> Bool -> TypeRenderOptions
TypeRenderOptions Bool
False Bool
True Bool
False

typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box
typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box
typeAsBoxImpl TypeRenderOptions
tro
  = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
internalError [Char]
"Incomplete pattern")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall u a b. Pattern u a b -> u -> a -> Maybe b
PA.pattern (TypeRenderOptions -> Pattern () PrettyPrintType Box
matchType TypeRenderOptions
tro) ()

-- | Generate a pretty-printed string representing a 'Type'
prettyPrintType :: Int -> Type a -> String
prettyPrintType :: forall a. Int -> Type a -> [Char]
prettyPrintType = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> TypeRenderOptions -> Type a -> [Char]
prettyPrintType' TypeRenderOptions
defaultOptions

-- | Generate a pretty-printed string representing a 'Type' using unicode
-- symbols where applicable
prettyPrintTypeWithUnicode :: Int -> Type a -> String
prettyPrintTypeWithUnicode :: forall a. Int -> Type a -> [Char]
prettyPrintTypeWithUnicode = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> TypeRenderOptions -> Type a -> [Char]
prettyPrintType' TypeRenderOptions
unicodeOptions

-- | Generate a pretty-printed string representing a suggested 'Type'
prettyPrintSuggestedType :: Type a -> String
prettyPrintSuggestedType :: forall a. Type a -> [Char]
prettyPrintSuggestedType = forall a. Int -> TypeRenderOptions -> Type a -> [Char]
prettyPrintType' forall a. Bounded a => a
maxBound TypeRenderOptions
suggestingOptions

prettyPrintType' :: Int -> TypeRenderOptions -> Type a -> String
prettyPrintType' :: forall a. Int -> TypeRenderOptions -> Type a -> [Char]
prettyPrintType' Int
maxDepth TypeRenderOptions
tro = Box -> [Char]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRenderOptions -> PrettyPrintType -> Box
typeAsBoxImpl TypeRenderOptions
tro forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Type a -> PrettyPrintType
convertPrettyPrintType Int
maxDepth

prettyPrintLabel :: Label -> Text
prettyPrintLabel :: Label -> Text
prettyPrintLabel (Label PSString
s) =
  case PSString -> Maybe Text
decodeString PSString
s of
    Just Text
s' | Bool -> Bool
not (Text -> Bool
objectKeyRequiresQuoting Text
s') ->
      Text
s'
    Maybe Text
_ ->
      PSString -> Text
prettyPrintString PSString
s

prettyPrintObjectKey :: PSString -> Text
prettyPrintObjectKey :: PSString -> Text
prettyPrintObjectKey = Label -> Text
prettyPrintLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSString -> Label
Label