-- | A "readable" Agda-like way to pretty-print PLC entities.

{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}

module PlutusCore.Pretty.Readable
    ( module Export
    , module PlutusCore.Pretty.Readable
    ) where

import PlutusPrelude

import PlutusCore.Pretty.ConfigName

import Control.Lens
import Text.Pretty
import Text.PrettyBy.Fixity as Export

data ShowKinds
    = ShowKindsYes
    | ShowKindsNo
    deriving stock (Int -> ShowKinds -> ShowS
[ShowKinds] -> ShowS
ShowKinds -> String
(Int -> ShowKinds -> ShowS)
-> (ShowKinds -> String)
-> ([ShowKinds] -> ShowS)
-> Show ShowKinds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowKinds] -> ShowS
$cshowList :: [ShowKinds] -> ShowS
show :: ShowKinds -> String
$cshow :: ShowKinds -> String
showsPrec :: Int -> ShowKinds -> ShowS
$cshowsPrec :: Int -> ShowKinds -> ShowS
Show, ShowKinds -> ShowKinds -> Bool
(ShowKinds -> ShowKinds -> Bool)
-> (ShowKinds -> ShowKinds -> Bool) -> Eq ShowKinds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowKinds -> ShowKinds -> Bool
$c/= :: ShowKinds -> ShowKinds -> Bool
== :: ShowKinds -> ShowKinds -> Bool
$c== :: ShowKinds -> ShowKinds -> Bool
Eq)

-- | Configuration for the readable pretty-printing.
data PrettyConfigReadable configName = PrettyConfigReadable
    { PrettyConfigReadable configName -> configName
_pcrConfigName    :: configName
    , PrettyConfigReadable configName -> RenderContext
_pcrRenderContext :: RenderContext
    , PrettyConfigReadable configName -> ShowKinds
_pcrShowKinds     :: ShowKinds
    }

type instance HasPrettyDefaults (PrettyConfigReadable _) = 'True

-- | The "readably pretty-printable" constraint.
type PrettyReadableBy configName = PrettyBy (PrettyConfigReadable configName)

type PrettyReadable = PrettyReadableBy PrettyConfigName

type HasPrettyConfigReadable env configName =
    HasPrettyConfig env (PrettyConfigReadable configName)

makeLenses ''PrettyConfigReadable

instance configName ~ PrettyConfigName => HasPrettyConfigName (PrettyConfigReadable configName) where
    toPrettyConfigName :: PrettyConfigReadable configName -> PrettyConfigName
toPrettyConfigName = PrettyConfigReadable configName -> PrettyConfigName
forall configName. PrettyConfigReadable configName -> configName
_pcrConfigName

instance HasRenderContext (PrettyConfigReadable configName) where
    renderContext :: (RenderContext -> f RenderContext)
-> PrettyConfigReadable configName
-> f (PrettyConfigReadable configName)
renderContext = (RenderContext -> f RenderContext)
-> PrettyConfigReadable configName
-> f (PrettyConfigReadable configName)
forall configName.
Lens' (PrettyConfigReadable configName) RenderContext
pcrRenderContext

-- | The fixity of a binder.
binderFixity :: Fixity
binderFixity :: Fixity
binderFixity = Associativity -> Precedence -> Fixity
forall prec. Associativity -> prec -> FixityOver prec
Fixity Associativity
RightAssociative Precedence
1

-- | The fixity of @(->)@.
arrowFixity :: Fixity
arrowFixity :: Fixity
arrowFixity = Associativity -> Precedence -> Fixity
forall prec. Associativity -> prec -> FixityOver prec
Fixity Associativity
RightAssociative Precedence
2

-- | A 'PrettyConfigReadable' with the fixity specified to 'botFixity'.
botPrettyConfigReadable :: configName -> ShowKinds -> PrettyConfigReadable configName
botPrettyConfigReadable :: configName -> ShowKinds -> PrettyConfigReadable configName
botPrettyConfigReadable configName
configName = configName
-> RenderContext -> ShowKinds -> PrettyConfigReadable configName
forall configName.
configName
-> RenderContext -> ShowKinds -> PrettyConfigReadable configName
PrettyConfigReadable configName
configName RenderContext
botRenderContext

-- | A 'PrettyConfigReadable' with the fixity specified to 'topFixity'.
topPrettyConfigReadable :: configName -> ShowKinds -> PrettyConfigReadable configName
topPrettyConfigReadable :: configName -> ShowKinds -> PrettyConfigReadable configName
topPrettyConfigReadable configName
configName = configName
-> RenderContext -> ShowKinds -> PrettyConfigReadable configName
forall configName.
configName
-> RenderContext -> ShowKinds -> PrettyConfigReadable configName
PrettyConfigReadable configName
configName RenderContext
topRenderContext

-- | Pretty-print two things with a @->@ between them.
arrowPrettyM
    :: (MonadPrettyContext config env m, PrettyBy config a, PrettyBy config b)
    => a -> b -> m (Doc ann)
arrowPrettyM :: a -> b -> m (Doc ann)
arrowPrettyM a
a b
b =
    Fixity
-> (AnyToDoc config ann -> AnyToDoc config ann -> Doc ann)
-> m (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
Fixity
-> (AnyToDoc config ann -> AnyToDoc config ann -> Doc ann)
-> m (Doc ann)
infixDocM Fixity
arrowFixity ((AnyToDoc config ann -> AnyToDoc config ann -> Doc ann)
 -> m (Doc ann))
-> (AnyToDoc config ann -> AnyToDoc config ann -> Doc ann)
-> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc config ann
prettyL AnyToDoc config ann
prettyR -> a -> Doc ann
AnyToDoc config ann
prettyL a
a 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
AnyToDoc config ann
prettyR b
b