-- |
-- Module      :  Cryptol.Utils.PP
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE Safe #-}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Utils.PP where

import           Cryptol.Utils.Fixity
import           Cryptol.Utils.Ident
import           Control.DeepSeq
import           Control.Monad (mplus)
import           Data.Maybe (fromMaybe)
import qualified Data.Semigroup as S
import           Data.String (IsString(..))
import qualified Data.Text as T
import           GHC.Generics (Generic)
import qualified Text.PrettyPrint as PJ

import Prelude ()
import Prelude.Compat


-- | How to pretty print things when evaluating
data PPOpts = PPOpts
  { PPOpts -> Bool
useAscii     :: Bool
  , PPOpts -> Int
useBase      :: Int
  , PPOpts -> Int
useInfLength :: Int
  , PPOpts -> Int
useFPBase    :: Int
  , PPOpts -> PPFloatFormat
useFPFormat  :: PPFloatFormat
  }
 deriving Int -> PPOpts -> ShowS
[PPOpts] -> ShowS
PPOpts -> String
(Int -> PPOpts -> ShowS)
-> (PPOpts -> String) -> ([PPOpts] -> ShowS) -> Show PPOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PPOpts] -> ShowS
$cshowList :: [PPOpts] -> ShowS
show :: PPOpts -> String
$cshow :: PPOpts -> String
showsPrec :: Int -> PPOpts -> ShowS
$cshowsPrec :: Int -> PPOpts -> ShowS
Show

asciiMode :: PPOpts -> Integer -> Bool
asciiMode :: PPOpts -> Integer -> Bool
asciiMode PPOpts
opts Integer
width = PPOpts -> Bool
useAscii PPOpts
opts Bool -> Bool -> Bool
&& (Integer
width Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
7 Bool -> Bool -> Bool
|| Integer
width Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
8)

data PPFloatFormat =
    FloatFixed Int PPFloatExp -- ^ Use this many significant digis
  | FloatFrac Int             -- ^ Show this many digits after floating point
  | FloatFree PPFloatExp      -- ^ Use the correct number of digits
 deriving Int -> PPFloatFormat -> ShowS
[PPFloatFormat] -> ShowS
PPFloatFormat -> String
(Int -> PPFloatFormat -> ShowS)
-> (PPFloatFormat -> String)
-> ([PPFloatFormat] -> ShowS)
-> Show PPFloatFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PPFloatFormat] -> ShowS
$cshowList :: [PPFloatFormat] -> ShowS
show :: PPFloatFormat -> String
$cshow :: PPFloatFormat -> String
showsPrec :: Int -> PPFloatFormat -> ShowS
$cshowsPrec :: Int -> PPFloatFormat -> ShowS
Show

data PPFloatExp = ForceExponent -- ^ Always show an exponent
                | AutoExponent  -- ^ Only show exponent when needed
 deriving Int -> PPFloatExp -> ShowS
[PPFloatExp] -> ShowS
PPFloatExp -> String
(Int -> PPFloatExp -> ShowS)
-> (PPFloatExp -> String)
-> ([PPFloatExp] -> ShowS)
-> Show PPFloatExp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PPFloatExp] -> ShowS
$cshowList :: [PPFloatExp] -> ShowS
show :: PPFloatExp -> String
$cshow :: PPFloatExp -> String
showsPrec :: Int -> PPFloatExp -> ShowS
$cshowsPrec :: Int -> PPFloatExp -> ShowS
Show


defaultPPOpts :: PPOpts
defaultPPOpts :: PPOpts
defaultPPOpts = PPOpts :: Bool -> Int -> Int -> Int -> PPFloatFormat -> PPOpts
PPOpts { useAscii :: Bool
useAscii = Bool
False, useBase :: Int
useBase = Int
10, useInfLength :: Int
useInfLength = Int
5
                       , useFPBase :: Int
useFPBase = Int
16
                       , useFPFormat :: PPFloatFormat
useFPFormat = PPFloatExp -> PPFloatFormat
FloatFree PPFloatExp
AutoExponent
                       }


-- Name Displaying -------------------------------------------------------------

{- | How to display names, inspired by the GHC `Outputable` module.
Getting a value of 'Nothing' from the NameDisp function indicates
that the display has no opinion on how this name should be displayed,
and some other display should be tried out. -}
data NameDisp = EmptyNameDisp
              | NameDisp (ModName -> Ident -> Maybe NameFormat)
                deriving ((forall x. NameDisp -> Rep NameDisp x)
-> (forall x. Rep NameDisp x -> NameDisp) -> Generic NameDisp
forall x. Rep NameDisp x -> NameDisp
forall x. NameDisp -> Rep NameDisp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NameDisp x -> NameDisp
$cfrom :: forall x. NameDisp -> Rep NameDisp x
Generic, NameDisp -> ()
(NameDisp -> ()) -> NFData NameDisp
forall a. (a -> ()) -> NFData a
rnf :: NameDisp -> ()
$crnf :: NameDisp -> ()
NFData)

instance Show NameDisp where
  show :: NameDisp -> String
show NameDisp
_ = String
"<NameDisp>"

instance S.Semigroup NameDisp where
  NameDisp ModName -> Ident -> Maybe NameFormat
f    <> :: NameDisp -> NameDisp -> NameDisp
<> NameDisp ModName -> Ident -> Maybe NameFormat
g    = (ModName -> Ident -> Maybe NameFormat) -> NameDisp
NameDisp (\ModName
m Ident
n -> ModName -> Ident -> Maybe NameFormat
f ModName
m Ident
n Maybe NameFormat -> Maybe NameFormat -> Maybe NameFormat
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ModName -> Ident -> Maybe NameFormat
g ModName
m Ident
n)
  NameDisp
EmptyNameDisp <> NameDisp
EmptyNameDisp = NameDisp
EmptyNameDisp
  NameDisp
EmptyNameDisp <> NameDisp
x             = NameDisp
x
  NameDisp
x             <> NameDisp
_             = NameDisp
x

instance Monoid NameDisp where
  mempty :: NameDisp
mempty = NameDisp
EmptyNameDisp
  mappend :: NameDisp -> NameDisp -> NameDisp
mappend = NameDisp -> NameDisp -> NameDisp
forall a. Semigroup a => a -> a -> a
(S.<>)

data NameFormat = UnQualified
                | Qualified !ModName
                | NotInScope
                  deriving (Int -> NameFormat -> ShowS
[NameFormat] -> ShowS
NameFormat -> String
(Int -> NameFormat -> ShowS)
-> (NameFormat -> String)
-> ([NameFormat] -> ShowS)
-> Show NameFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NameFormat] -> ShowS
$cshowList :: [NameFormat] -> ShowS
show :: NameFormat -> String
$cshow :: NameFormat -> String
showsPrec :: Int -> NameFormat -> ShowS
$cshowsPrec :: Int -> NameFormat -> ShowS
Show)

-- | Never qualify names from this module.
neverQualifyMod :: ModName -> NameDisp
neverQualifyMod :: ModName -> NameDisp
neverQualifyMod ModName
mn = (ModName -> Ident -> Maybe NameFormat) -> NameDisp
NameDisp ((ModName -> Ident -> Maybe NameFormat) -> NameDisp)
-> (ModName -> Ident -> Maybe NameFormat) -> NameDisp
forall a b. (a -> b) -> a -> b
$ \ ModName
mn' Ident
_ ->
  if ModName
mn ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
== ModName
mn' then NameFormat -> Maybe NameFormat
forall a. a -> Maybe a
Just NameFormat
UnQualified
               else Maybe NameFormat
forall a. Maybe a
Nothing

alwaysQualify :: NameDisp
alwaysQualify :: NameDisp
alwaysQualify  = (ModName -> Ident -> Maybe NameFormat) -> NameDisp
NameDisp ((ModName -> Ident -> Maybe NameFormat) -> NameDisp)
-> (ModName -> Ident -> Maybe NameFormat) -> NameDisp
forall a b. (a -> b) -> a -> b
$ \ ModName
mn Ident
_ -> NameFormat -> Maybe NameFormat
forall a. a -> Maybe a
Just (ModName -> NameFormat
Qualified ModName
mn)

neverQualify :: NameDisp
neverQualify :: NameDisp
neverQualify  = (ModName -> Ident -> Maybe NameFormat) -> NameDisp
NameDisp ((ModName -> Ident -> Maybe NameFormat) -> NameDisp)
-> (ModName -> Ident -> Maybe NameFormat) -> NameDisp
forall a b. (a -> b) -> a -> b
$ \ ModName
_ Ident
_ -> NameFormat -> Maybe NameFormat
forall a. a -> Maybe a
Just NameFormat
UnQualified

fmtModName :: ModName -> NameFormat -> T.Text
fmtModName :: ModName -> NameFormat -> Text
fmtModName ModName
_  NameFormat
UnQualified    = Text
T.empty
fmtModName ModName
_  (Qualified ModName
mn) = ModName -> Text
modNameToText ModName
mn
fmtModName ModName
mn NameFormat
NotInScope     = ModName -> Text
modNameToText ModName
mn

-- | Compose two naming environments, preferring names from the left
-- environment.
extend :: NameDisp -> NameDisp -> NameDisp
extend :: NameDisp -> NameDisp -> NameDisp
extend  = NameDisp -> NameDisp -> NameDisp
forall a. Monoid a => a -> a -> a
mappend

-- | Get the format for a name. When 'Nothing' is returned, the name is not
-- currently in scope.
getNameFormat :: ModName -> Ident -> NameDisp -> NameFormat
getNameFormat :: ModName -> Ident -> NameDisp -> NameFormat
getNameFormat ModName
m Ident
i (NameDisp ModName -> Ident -> Maybe NameFormat
f)  = NameFormat -> Maybe NameFormat -> NameFormat
forall a. a -> Maybe a -> a
fromMaybe NameFormat
NotInScope (ModName -> Ident -> Maybe NameFormat
f ModName
m Ident
i)
getNameFormat ModName
_ Ident
_ NameDisp
EmptyNameDisp = NameFormat
NotInScope

-- | Produce a document in the context of the current 'NameDisp'.
withNameDisp :: (NameDisp -> Doc) -> Doc
withNameDisp :: (NameDisp -> Doc) -> Doc
withNameDisp NameDisp -> Doc
k = (NameDisp -> Doc) -> Doc
Doc (\NameDisp
disp -> NameDisp -> Doc -> Doc
runDoc NameDisp
disp (NameDisp -> Doc
k NameDisp
disp))

-- | Fix the way that names are displayed inside of a doc.
fixNameDisp :: NameDisp -> Doc -> Doc
fixNameDisp :: NameDisp -> Doc -> Doc
fixNameDisp NameDisp
disp (Doc NameDisp -> Doc
f) = (NameDisp -> Doc) -> Doc
Doc (\ NameDisp
_ -> NameDisp -> Doc
f NameDisp
disp)


-- Documents -------------------------------------------------------------------

newtype Doc = Doc (NameDisp -> PJ.Doc) deriving ((forall x. Doc -> Rep Doc x)
-> (forall x. Rep Doc x -> Doc) -> Generic Doc
forall x. Rep Doc x -> Doc
forall x. Doc -> Rep Doc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Doc x -> Doc
$cfrom :: forall x. Doc -> Rep Doc x
Generic, Doc -> ()
(Doc -> ()) -> NFData Doc
forall a. (a -> ()) -> NFData a
rnf :: Doc -> ()
$crnf :: Doc -> ()
NFData)

instance S.Semigroup Doc where
  <> :: Doc -> Doc -> Doc
(<>) = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
liftPJ2 Doc -> Doc -> Doc
(PJ.<>)

instance Monoid Doc where
  mempty :: Doc
mempty = Doc -> Doc
liftPJ Doc
PJ.empty
  mappend :: Doc -> Doc -> Doc
mappend = Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(S.<>)

runDoc :: NameDisp -> Doc -> PJ.Doc
runDoc :: NameDisp -> Doc -> Doc
runDoc NameDisp
names (Doc NameDisp -> Doc
f) = NameDisp -> Doc
f NameDisp
names

instance Show Doc where
  show :: Doc -> String
show Doc
d = Doc -> String
forall a. Show a => a -> String
show (NameDisp -> Doc -> Doc
runDoc NameDisp
forall a. Monoid a => a
mempty Doc
d)

instance IsString Doc where
  fromString :: String -> Doc
fromString = String -> Doc
text

render :: Doc -> String
render :: Doc -> String
render Doc
d = Doc -> String
PJ.render (NameDisp -> Doc -> Doc
runDoc NameDisp
forall a. Monoid a => a
mempty Doc
d)

renderOneLine :: Doc -> String
renderOneLine :: Doc -> String
renderOneLine Doc
d = Style -> Doc -> String
PJ.renderStyle (Style
PJ.style { mode :: Mode
PJ.mode = Mode
PJ.OneLineMode }) (NameDisp -> Doc -> Doc
runDoc NameDisp
forall a. Monoid a => a
mempty Doc
d)

class PP a where
  ppPrec :: Int -> a -> Doc

class PP a => PPName a where
  -- | Fixity information for infix operators
  ppNameFixity :: a -> Maybe Fixity

  -- | Print a name in prefix: @f a b@ or @(+) a b)@
  ppPrefixName :: a -> Doc

  -- | Print a name as an infix operator: @a + b@
  ppInfixName  :: a -> Doc

pp :: PP a => a -> Doc
pp :: a -> Doc
pp = Int -> a -> Doc
forall a. PP a => Int -> a -> Doc
ppPrec Int
0

pretty :: PP a => a -> String
pretty :: a -> String
pretty  = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. PP a => a -> Doc
pp

optParens :: Bool -> Doc -> Doc
optParens :: Bool -> Doc -> Doc
optParens Bool
b Doc
body | Bool
b         = Doc -> Doc
parens Doc
body
                 | Bool
otherwise = Doc
body


-- | Information about an infix expression of some sort.
data Infix op thing = Infix
  { Infix op thing -> op
ieOp     :: op       -- ^ operator
  , Infix op thing -> thing
ieLeft   :: thing    -- ^ left argument
  , Infix op thing -> thing
ieRight  :: thing    -- ^ right argument
  , Infix op thing -> Fixity
ieFixity :: Fixity   -- ^ operator fixity
  }

commaSep :: [Doc] -> Doc
commaSep :: [Doc] -> Doc
commaSep = [Doc] -> Doc
fsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma


-- | Pretty print an infix expression of some sort.
ppInfix :: (PP thing, PP op)
        => Int            -- ^ Non-infix leaves are printed with this precedence
        -> (thing -> Maybe (Infix op thing))
                          -- ^ pattern to check if sub-thing is also infix
        -> Infix op thing -- ^ Pretty print this infix expression
        -> Doc
ppInfix :: Int -> (thing -> Maybe (Infix op thing)) -> Infix op thing -> Doc
ppInfix Int
lp thing -> Maybe (Infix op thing)
isInfix Infix op thing
expr =
  [Doc] -> Doc
sep [ (Fixity -> Bool) -> thing -> Doc
ppSub Fixity -> Bool
wrapL (Infix op thing -> thing
forall op thing. Infix op thing -> thing
ieLeft Infix op thing
expr) Doc -> Doc -> Doc
<+> op -> Doc
forall a. PP a => a -> Doc
pp (Infix op thing -> op
forall op thing. Infix op thing -> op
ieOp Infix op thing
expr)
      , (Fixity -> Bool) -> thing -> Doc
ppSub Fixity -> Bool
wrapR (Infix op thing -> thing
forall op thing. Infix op thing -> thing
ieRight Infix op thing
expr) ]
  where
    wrapL :: Fixity -> Bool
wrapL Fixity
f = Fixity -> Fixity -> FixityCmp
compareFixity Fixity
f (Infix op thing -> Fixity
forall op thing. Infix op thing -> Fixity
ieFixity Infix op thing
expr) FixityCmp -> FixityCmp -> Bool
forall a. Eq a => a -> a -> Bool
/= FixityCmp
FCLeft
    wrapR :: Fixity -> Bool
wrapR Fixity
f = Fixity -> Fixity -> FixityCmp
compareFixity (Infix op thing -> Fixity
forall op thing. Infix op thing -> Fixity
ieFixity Infix op thing
expr) Fixity
f FixityCmp -> FixityCmp -> Bool
forall a. Eq a => a -> a -> Bool
/= FixityCmp
FCRight

    ppSub :: (Fixity -> Bool) -> thing -> Doc
ppSub Fixity -> Bool
w thing
e
      | Just Infix op thing
e1 <- thing -> Maybe (Infix op thing)
isInfix thing
e = Bool -> Doc -> Doc
optParens (Fixity -> Bool
w (Infix op thing -> Fixity
forall op thing. Infix op thing -> Fixity
ieFixity Infix op thing
e1)) (Int -> (thing -> Maybe (Infix op thing)) -> Infix op thing -> Doc
forall thing op.
(PP thing, PP op) =>
Int -> (thing -> Maybe (Infix op thing)) -> Infix op thing -> Doc
ppInfix Int
lp thing -> Maybe (Infix op thing)
isInfix Infix op thing
e1)
    ppSub Fixity -> Bool
_ thing
e                = Int -> thing -> Doc
forall a. PP a => Int -> a -> Doc
ppPrec Int
lp thing
e



-- | Display a numeric value as an ordinal (e.g., 2nd)
ordinal :: (Integral a, Show a, Eq a) => a -> Doc
ordinal :: a -> Doc
ordinal a
x = String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
x) Doc -> Doc -> Doc
<.> String -> Doc
text (a -> String
forall a. (Integral a, Eq a) => a -> String
ordSuffix a
x)

-- | The suffix to use when displaying a number as an oridinal
ordSuffix :: (Integral a, Eq a) => a -> String
ordSuffix :: a -> String
ordSuffix a
n0 =
  case a
n a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
10 of
    a
1 | Bool
notTeen -> String
"st"
    a
2 | Bool
notTeen -> String
"nd"
    a
3 | Bool
notTeen -> String
"rd"
    a
_ -> String
"th"

  where
  n :: a
n       = a -> a
forall a. Num a => a -> a
abs a
n0
  m :: a
m       = a
n a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
100
  notTeen :: Bool
notTeen = a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
11 Bool -> Bool -> Bool
|| a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
19


-- Wrapped Combinators ---------------------------------------------------------

liftPJ :: PJ.Doc -> Doc
liftPJ :: Doc -> Doc
liftPJ Doc
d = (NameDisp -> Doc) -> Doc
Doc (Doc -> NameDisp -> Doc
forall a b. a -> b -> a
const Doc
d)

liftPJ1 :: (PJ.Doc -> PJ.Doc) -> Doc -> Doc
liftPJ1 :: (Doc -> Doc) -> Doc -> Doc
liftPJ1 Doc -> Doc
f (Doc NameDisp -> Doc
d) = (NameDisp -> Doc) -> Doc
Doc (\NameDisp
env -> Doc -> Doc
f (NameDisp -> Doc
d NameDisp
env))

liftPJ2 :: (PJ.Doc -> PJ.Doc -> PJ.Doc) -> (Doc -> Doc -> Doc)
liftPJ2 :: (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
liftPJ2 Doc -> Doc -> Doc
f (Doc NameDisp -> Doc
a) (Doc NameDisp -> Doc
b) = (NameDisp -> Doc) -> Doc
Doc (\NameDisp
e -> Doc -> Doc -> Doc
f (NameDisp -> Doc
a NameDisp
e) (NameDisp -> Doc
b NameDisp
e))

liftSep :: ([PJ.Doc] -> PJ.Doc) -> ([Doc] -> Doc)
liftSep :: ([Doc] -> Doc) -> [Doc] -> Doc
liftSep [Doc] -> Doc
f [Doc]
ds = (NameDisp -> Doc) -> Doc
Doc (\NameDisp
e -> [Doc] -> Doc
f [ NameDisp -> Doc
d NameDisp
e | Doc NameDisp -> Doc
d <- [Doc]
ds ])

infixl 6 <.>, <+>

(<.>) :: Doc -> Doc -> Doc
<.> :: Doc -> Doc -> Doc
(<.>)  = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
liftPJ2 Doc -> Doc -> Doc
(PJ.<>)

(<+>) :: Doc -> Doc -> Doc
<+> :: Doc -> Doc -> Doc
(<+>)  = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
liftPJ2 Doc -> Doc -> Doc
(PJ.<+>)

infixl 5 $$

($$) :: Doc -> Doc -> Doc
$$ :: Doc -> Doc -> Doc
($$)  = (Doc -> Doc -> Doc) -> Doc -> Doc -> Doc
liftPJ2 Doc -> Doc -> Doc
(PJ.$$)

sep :: [Doc] -> Doc
sep :: [Doc] -> Doc
sep  = ([Doc] -> Doc) -> [Doc] -> Doc
liftSep [Doc] -> Doc
PJ.sep

fsep :: [Doc] -> Doc
fsep :: [Doc] -> Doc
fsep  = ([Doc] -> Doc) -> [Doc] -> Doc
liftSep [Doc] -> Doc
PJ.fsep

hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep  = ([Doc] -> Doc) -> [Doc] -> Doc
liftSep [Doc] -> Doc
PJ.hsep

hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat  = ([Doc] -> Doc) -> [Doc] -> Doc
liftSep [Doc] -> Doc
PJ.hcat

vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat  = ([Doc] -> Doc) -> [Doc] -> Doc
liftSep [Doc] -> Doc
PJ.vcat

hang :: Doc -> Int -> Doc -> Doc
hang :: Doc -> Int -> Doc -> Doc
hang (Doc NameDisp -> Doc
p) Int
i (Doc NameDisp -> Doc
q) = (NameDisp -> Doc) -> Doc
Doc (\NameDisp
e -> Doc -> Int -> Doc -> Doc
PJ.hang (NameDisp -> Doc
p NameDisp
e) Int
i (NameDisp -> Doc
q NameDisp
e))

nest :: Int -> Doc -> Doc
nest :: Int -> Doc -> Doc
nest Int
n = (Doc -> Doc) -> Doc -> Doc
liftPJ1 (Int -> Doc -> Doc
PJ.nest Int
n)

parens :: Doc -> Doc
parens :: Doc -> Doc
parens  = (Doc -> Doc) -> Doc -> Doc
liftPJ1 Doc -> Doc
PJ.parens

braces :: Doc -> Doc
braces :: Doc -> Doc
braces  = (Doc -> Doc) -> Doc -> Doc
liftPJ1 Doc -> Doc
PJ.braces

brackets :: Doc -> Doc
brackets :: Doc -> Doc
brackets  = (Doc -> Doc) -> Doc -> Doc
liftPJ1 Doc -> Doc
PJ.brackets

quotes :: Doc -> Doc
quotes :: Doc -> Doc
quotes  = (Doc -> Doc) -> Doc -> Doc
liftPJ1 Doc -> Doc
PJ.quotes

backticks :: Doc -> Doc
backticks :: Doc -> Doc
backticks Doc
d = [Doc] -> Doc
hcat [ Doc
"`", Doc
d, Doc
"`" ]

punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate Doc
p = [Doc] -> [Doc]
go
  where
  go :: [Doc] -> [Doc]
go (Doc
d:[Doc]
ds) | [Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
ds   = [Doc
d]
            | Bool
otherwise = Doc
d Doc -> Doc -> Doc
<.> Doc
p Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
go [Doc]
ds
  go []                 = []

text :: String -> Doc
text :: String -> Doc
text String
s = Doc -> Doc
liftPJ (String -> Doc
PJ.text String
s)

char :: Char -> Doc
char :: Char -> Doc
char Char
c = Doc -> Doc
liftPJ (Char -> Doc
PJ.char Char
c)

integer :: Integer -> Doc
integer :: Integer -> Doc
integer Integer
i = Doc -> Doc
liftPJ (Integer -> Doc
PJ.integer Integer
i)

int :: Int -> Doc
int :: Int -> Doc
int Int
i = Doc -> Doc
liftPJ (Int -> Doc
PJ.int Int
i)

comma :: Doc
comma :: Doc
comma  = Doc -> Doc
liftPJ Doc
PJ.comma

empty :: Doc
empty :: Doc
empty  = Doc -> Doc
liftPJ Doc
PJ.empty

colon :: Doc
colon :: Doc
colon  = Doc -> Doc
liftPJ Doc
PJ.colon

instance PP T.Text where
  ppPrec :: Int -> Text -> Doc
ppPrec Int
_ Text
str = String -> Doc
text (Text -> String
T.unpack Text
str)

instance PP Ident where
  ppPrec :: Int -> Ident -> Doc
ppPrec Int
_ Ident
i = String -> Doc
text (Text -> String
T.unpack (Ident -> Text
identText Ident
i))

instance PP ModName where
  ppPrec :: Int -> ModName -> Doc
ppPrec Int
_   = String -> Doc
text (String -> Doc) -> (ModName -> String) -> ModName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (ModName -> Text) -> ModName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModName -> Text
modNameToText

instance PP Assoc where
  ppPrec :: Int -> Assoc -> Doc
ppPrec Int
_ Assoc
LeftAssoc  = String -> Doc
text String
"left-associative"
  ppPrec Int
_ Assoc
RightAssoc = String -> Doc
text String
"right-associative"
  ppPrec Int
_ Assoc
NonAssoc   = String -> Doc
text String
"non-associative"

instance PP Fixity where
  ppPrec :: Int -> Fixity -> Doc
ppPrec Int
_ (Fixity Assoc
assoc Int
level) =
    String -> Doc
text String
"precedence" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
level Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
<+> Assoc -> Doc
forall a. PP a => a -> Doc
pp Assoc
assoc