-- |

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.Lens (_2, (%~))

import Control.PatternArrows as PA

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(..), TypeVarVisibility(..), WildcardData(..), eqType, rowToSortedList, typeVarVisibilityPrefix)

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 [(TypeVarVisibility, 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 = go

where

go _ (TUnknown _ n) = PPTUnknown n

go _ (TypeVar _ t) = PPTypeVar t Nothing

go _ (TypeLevelString _ s) = PPTypeLevelString s

go _ (TypeLevelInt _ n) = PPTypeLevelInt n

go _ (TypeWildcard _ (HoleWildcard n)) = PPTypeWildcard (Just n)

go _ (TypeWildcard _ _) = PPTypeWildcard Nothing

go _ (TypeConstructor _ c) = PPTypeConstructor c

go _ (TypeOp _ o) = PPTypeOp o

go _ (Skolem _ t _ n _) = PPSkolem t n

go _ (REmpty _) = PPRow [] 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 d _ | d < 0 = PPTruncated

go d (ConstrainedType _ (Constraint _ cls kargs args _) ty) = PPConstrainedType (cls, go (d-1) <$> kargs, go (d-1) <$> args) (go d ty)

go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (go (d-1) k)

go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3)

go d (ParensInType _ ty) = PPParensInType (go (d-1) ty)

go d ty@RCons{} = uncurry PPRow (goRow d ty)

go d (ForAll _ vis v mbK ty _) = goForAll d [(vis, v, fmap (go (d-1)) mbK)] ty

go d (TypeApp _ a b) = goTypeApp d a b

go d (KindApp _ a b) = PPTypeApp (go (d-1) a) (PPKindArg (go (d-1) b))

goForAll d vs (ForAll _ vis v mbK ty _) = goForAll d ((vis, v, fmap (go (d-1)) mbK) : vs) ty

goForAll d vs ty = PPForAll (reverse vs) (go (d-1) ty)

goRow d ty =

let (items, tail_) = rowToSortedList ty

in ( map (\item -> (rowListLabel item, go (d-1) (rowListType item))) items

, case tail_ of

REmptyKinded _ _ -> Nothing

_ -> Just (go (d-1) tail_)

)

goTypeApp d (TypeApp _ f a) b

| eqType f tyFunction = PPFunction (go (d-1) a) (go (d-1) b)

| otherwise = PPTypeApp (goTypeApp d f a) (go (d-1) b)

goTypeApp d o ty@RCons{}

| eqType o tyRecord = uncurry PPRecord (goRow d ty)

goTypeApp d a b = PPTypeApp (go (d-1) a) (go (d-1) b)

constraintsAsBox :: TypeRenderOptions -> PrettyPrintConstraint -> Box -> Box

constraintsAsBox tro con ty =

constraintAsBox con `before` (" " <> text doubleRightArrow <> " " <> ty)

where

doubleRightArrow = if troUnicode tro then "⇒" else "=>"

constraintAsBox :: PrettyPrintConstraint -> Box

constraintAsBox (pn, ks, tys) = typeAsBox' (foldl PPTypeApp (foldl (\a b -> PPTypeApp a (PPKindArg b)) (PPTypeConstructor (fmap coerceProperName pn)) ks) tys)

-- |

prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> Box

prettyPrintRowWith tro open close labels rest =

case (labels, rest) of

([], Nothing) ->

if troRowAsDiff tro then text [ open, ' ' ] <> text "..." <> text [ ' ', close ] else text [ open, close ]

([], Just _) ->

text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]

_ ->

vcat left $

zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) labels [0 :: Int ..] ++

catMaybes [ rowDiff, pure $ tailToPs rest, pure $ text [close] ]

where

nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box

nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox' ty

doubleColon = if troUnicode tro then "∷" else "::"

rowDiff = if troRowAsDiff tro then Just (text "...") else Nothing

tailToPs :: Maybe PrettyPrintType -> Box

tailToPs Nothing = nullBox

tailToPs (Just other) = text "| " <> typeAsBox' other

typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)

typeApp = mkPattern match

where

match (PPTypeApp f x) = Just (f, x)

match _ = Nothing

kindArg :: Pattern () PrettyPrintType ((), PrettyPrintType)

kindArg = mkPattern match

where

match (PPKindArg ty) = Just ((), ty)

match _ = Nothing

appliedFunction :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)

appliedFunction = mkPattern match

where

match (PPFunction arg ret) = Just (arg, ret)

match _ = Nothing

kinded :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType)

kinded = mkPattern match

where

match (PPKindedType t k) = Just (t, k)

match _ = Nothing

constrained :: Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType)

constrained = mkPattern match

where

match (PPConstrainedType deps ty) = Just (deps, ty)

match _ = Nothing

explicitParens :: Pattern () PrettyPrintType ((), PrettyPrintType)

explicitParens = mkPattern match

where

match (PPParensInType ty) = Just ((), ty)

match _ = Nothing

matchTypeAtom :: TypeRenderOptions -> Pattern () PrettyPrintType Box

matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =

typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) (matchType tro)

where

typeLiterals :: Pattern () PrettyPrintType Box

typeLiterals = mkPattern match where

match (PPTypeWildcard name) = Just $ text $ maybe "_" (('?' :) . T.unpack) name

match (PPTypeVar var _) = Just $ text $ T.unpack var

match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s

match (PPTypeLevelInt n) = Just $ text $ show n

match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor

match (PPTUnknown u)

| suggesting = Just $ text "_"

| otherwise = Just $ text $ 't' : show u

match (PPSkolem name s)

| suggesting = Just $ text $ T.unpack name

| otherwise = Just $ text $ T.unpack name ++ show s

match (PPRecord labels tail_) = Just $ prettyPrintRowWith tro '{' '}' labels tail_

match (PPRow labels tail_) = Just $ prettyPrintRowWith tro '(' ')' labels tail_

match (PPBinaryNoParensType op l r) =

Just $ typeAsBox' l <> text " " <> typeAsBox' op <> text " " <> typeAsBox' r

match (PPTypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op

match PPTruncated = Just $ text "..."

match _ = Nothing

matchType :: TypeRenderOptions -> Pattern () PrettyPrintType Box

matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where

operators :: OperatorTable () PrettyPrintType Box

operators =

OperatorTable [ [ Wrap kindArg $ \_ ty -> text "@" <> ty ]

, [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]

, [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ]

, [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ]

, [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (hsep 1 top (text forall' : fmap printMbKindedType idents) <> text ".") ty ]

, [ Wrap kinded $ \ty k -> keepSingleLinesOr (moveRight 2) (typeAsBox' ty) (text (doubleColon ++ " ") <> k) ]

, [ Wrap explicitParens $ \_ ty -> ty ]

]

rightArrow = if troUnicode tro then "→" else "->"

forall' = if troUnicode tro then "∀" else "forall"

doubleColon = if troUnicode tro then "∷" else "::"

printMbKindedType (vis, v, Nothing) = text (T.unpack $ typeVarVisibilityPrefix vis) <> text v

printMbKindedType (vis, v, Just k) = text ("(" ++ T.unpack (typeVarVisibilityPrefix vis) ++ v ++ " " ++ doubleColon ++ " ") <> typeAsBox' k <> text ")"

-- 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 f b1 b2

| rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ]

| otherwise = hcat top [ b1, text " ", b2]

forall_ :: Pattern () PrettyPrintType ([(TypeVarVisibility, String, Maybe PrettyPrintType)], PrettyPrintType)

forall_ = mkPattern match

where

match (PPForAll idents ty) = Just ((_2 %~ T.unpack) <$> idents, ty)

match _ = Nothing

typeAtomAsBox' :: PrettyPrintType -> Box

typeAtomAsBox'

= fromMaybe (internalError "Incomplete pattern")

. PA.pattern_ (matchTypeAtom defaultOptions) ()

typeAtomAsBox :: Int -> Type a -> Box

typeAtomAsBox maxDepth = typeAtomAsBox' . convertPrettyPrintType maxDepth

-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

prettyPrintTypeAtom :: Int -> Type a -> String

prettyPrintTypeAtom maxDepth = render . typeAtomAsBox maxDepth

typeAsBox' :: PrettyPrintType -> Box

typeAsBox' = typeAsBoxImpl defaultOptions

typeAsBox :: Int -> Type a -> Box

typeAsBox maxDepth = typeAsBox' . convertPrettyPrintType maxDepth

typeDiffAsBox' :: PrettyPrintType -> Box

typeDiffAsBox' = typeAsBoxImpl diffOptions

typeDiffAsBox :: Int -> Type a -> Box

typeDiffAsBox maxDepth = typeDiffAsBox' . convertPrettyPrintType maxDepth

data TypeRenderOptions = TypeRenderOptions

{ troSuggesting :: Bool

, troUnicode :: Bool

, troRowAsDiff :: Bool

}

suggestingOptions :: TypeRenderOptions

suggestingOptions = TypeRenderOptions True False False

defaultOptions :: TypeRenderOptions

defaultOptions = TypeRenderOptions False False False

diffOptions :: TypeRenderOptions

diffOptions = TypeRenderOptions False False True

unicodeOptions :: TypeRenderOptions

unicodeOptions = TypeRenderOptions False True False

typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box

typeAsBoxImpl tro

= fromMaybe (internalError "Incomplete pattern")

. PA.pattern_ (matchType tro) ()

-- | Generate a pretty-printed string representing a 'Type'

prettyPrintType :: Int -> Type a -> String

prettyPrintType = flip prettyPrintType' defaultOptions

-- | Generate a pretty-printed string representing a 'Type' using unicode

prettyPrintTypeWithUnicode :: Int -> Type a -> String

prettyPrintTypeWithUnicode = flip prettyPrintType' unicodeOptions

-- | Generate a pretty-printed string representing a suggested 'Type'

prettyPrintSuggestedType :: Type a -> String

prettyPrintSuggestedType = prettyPrintType' maxBound suggestingOptions

prettyPrintType' :: Int -> TypeRenderOptions -> Type a -> String

prettyPrintType' maxDepth tro = render . typeAsBoxImpl tro . convertPrettyPrintType maxDepth

prettyPrintLabel :: Label -> Text

prettyPrintLabel (Label s) =

case decodeString s of

Just s' | not (objectKeyRequiresQuoting s') ->

s'

_ ->

prettyPrintString s

prettyPrintObjectKey :: PSString -> Text

prettyPrintObjectKey = prettyPrintLabel . Label