-- HLint is confused by the identifier `pattern` if PatternSynonyms is enabled.
{-# LANGUAGE NoPatternSynonyms #-}

-- |
-- 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 qualified Data.Text as T

import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Names
import Language.PureScript.Pretty.Common
import Language.PureScript.Types
import Language.PureScript.PSString (PSString, prettyPrintString, decodeString)
import Language.PureScript.Label (Label(..))

import Text.PrettyPrint.Boxes hiding ((<+>))

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