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

{-# LANGUAGE Safe #-}
{-# LANGUAGE BlockArguments #-}
{-# 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           Data.String (IsString(..))
import qualified Data.Text as T
import           Data.Void (Void)
import           GHC.Generics (Generic)
import qualified Prettyprinter as PP
import qualified Prettyprinter.Util as PP
import qualified Prettyprinter.Render.String as PP

-- | 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
  , PPOpts -> FieldOrder
useFieldOrder :: FieldOrder
  }
 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
$cshowsPrec :: Int -> PPOpts -> ShowS
showsPrec :: Int -> PPOpts -> ShowS
$cshow :: PPOpts -> String
show :: PPOpts -> String
$cshowList :: [PPOpts] -> ShowS
showList :: [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
$cshowsPrec :: Int -> PPFloatFormat -> ShowS
showsPrec :: Int -> PPFloatFormat -> ShowS
$cshow :: PPFloatFormat -> String
show :: PPFloatFormat -> String
$cshowList :: [PPFloatFormat] -> ShowS
showList :: [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
$cshowsPrec :: Int -> PPFloatExp -> ShowS
showsPrec :: Int -> PPFloatExp -> ShowS
$cshow :: PPFloatExp -> String
show :: PPFloatExp -> String
$cshowList :: [PPFloatExp] -> ShowS
showList :: [PPFloatExp] -> ShowS
Show

data FieldOrder = DisplayOrder | CanonicalOrder
  deriving (FieldOrder
FieldOrder -> FieldOrder -> Bounded FieldOrder
forall a. a -> a -> Bounded a
$cminBound :: FieldOrder
minBound :: FieldOrder
$cmaxBound :: FieldOrder
maxBound :: FieldOrder
Bounded, Int -> FieldOrder
FieldOrder -> Int
FieldOrder -> [FieldOrder]
FieldOrder -> FieldOrder
FieldOrder -> FieldOrder -> [FieldOrder]
FieldOrder -> FieldOrder -> FieldOrder -> [FieldOrder]
(FieldOrder -> FieldOrder)
-> (FieldOrder -> FieldOrder)
-> (Int -> FieldOrder)
-> (FieldOrder -> Int)
-> (FieldOrder -> [FieldOrder])
-> (FieldOrder -> FieldOrder -> [FieldOrder])
-> (FieldOrder -> FieldOrder -> [FieldOrder])
-> (FieldOrder -> FieldOrder -> FieldOrder -> [FieldOrder])
-> Enum FieldOrder
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: FieldOrder -> FieldOrder
succ :: FieldOrder -> FieldOrder
$cpred :: FieldOrder -> FieldOrder
pred :: FieldOrder -> FieldOrder
$ctoEnum :: Int -> FieldOrder
toEnum :: Int -> FieldOrder
$cfromEnum :: FieldOrder -> Int
fromEnum :: FieldOrder -> Int
$cenumFrom :: FieldOrder -> [FieldOrder]
enumFrom :: FieldOrder -> [FieldOrder]
$cenumFromThen :: FieldOrder -> FieldOrder -> [FieldOrder]
enumFromThen :: FieldOrder -> FieldOrder -> [FieldOrder]
$cenumFromTo :: FieldOrder -> FieldOrder -> [FieldOrder]
enumFromTo :: FieldOrder -> FieldOrder -> [FieldOrder]
$cenumFromThenTo :: FieldOrder -> FieldOrder -> FieldOrder -> [FieldOrder]
enumFromThenTo :: FieldOrder -> FieldOrder -> FieldOrder -> [FieldOrder]
Enum, FieldOrder -> FieldOrder -> Bool
(FieldOrder -> FieldOrder -> Bool)
-> (FieldOrder -> FieldOrder -> Bool) -> Eq FieldOrder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldOrder -> FieldOrder -> Bool
== :: FieldOrder -> FieldOrder -> Bool
$c/= :: FieldOrder -> FieldOrder -> Bool
/= :: FieldOrder -> FieldOrder -> Bool
Eq, Eq FieldOrder
Eq FieldOrder =>
(FieldOrder -> FieldOrder -> Ordering)
-> (FieldOrder -> FieldOrder -> Bool)
-> (FieldOrder -> FieldOrder -> Bool)
-> (FieldOrder -> FieldOrder -> Bool)
-> (FieldOrder -> FieldOrder -> Bool)
-> (FieldOrder -> FieldOrder -> FieldOrder)
-> (FieldOrder -> FieldOrder -> FieldOrder)
-> Ord FieldOrder
FieldOrder -> FieldOrder -> Bool
FieldOrder -> FieldOrder -> Ordering
FieldOrder -> FieldOrder -> FieldOrder
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FieldOrder -> FieldOrder -> Ordering
compare :: FieldOrder -> FieldOrder -> Ordering
$c< :: FieldOrder -> FieldOrder -> Bool
< :: FieldOrder -> FieldOrder -> Bool
$c<= :: FieldOrder -> FieldOrder -> Bool
<= :: FieldOrder -> FieldOrder -> Bool
$c> :: FieldOrder -> FieldOrder -> Bool
> :: FieldOrder -> FieldOrder -> Bool
$c>= :: FieldOrder -> FieldOrder -> Bool
>= :: FieldOrder -> FieldOrder -> Bool
$cmax :: FieldOrder -> FieldOrder -> FieldOrder
max :: FieldOrder -> FieldOrder -> FieldOrder
$cmin :: FieldOrder -> FieldOrder -> FieldOrder
min :: FieldOrder -> FieldOrder -> FieldOrder
Ord, ReadPrec [FieldOrder]
ReadPrec FieldOrder
Int -> ReadS FieldOrder
ReadS [FieldOrder]
(Int -> ReadS FieldOrder)
-> ReadS [FieldOrder]
-> ReadPrec FieldOrder
-> ReadPrec [FieldOrder]
-> Read FieldOrder
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS FieldOrder
readsPrec :: Int -> ReadS FieldOrder
$creadList :: ReadS [FieldOrder]
readList :: ReadS [FieldOrder]
$creadPrec :: ReadPrec FieldOrder
readPrec :: ReadPrec FieldOrder
$creadListPrec :: ReadPrec [FieldOrder]
readListPrec :: ReadPrec [FieldOrder]
Read, Int -> FieldOrder -> ShowS
[FieldOrder] -> ShowS
FieldOrder -> String
(Int -> FieldOrder -> ShowS)
-> (FieldOrder -> String)
-> ([FieldOrder] -> ShowS)
-> Show FieldOrder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldOrder -> ShowS
showsPrec :: Int -> FieldOrder -> ShowS
$cshow :: FieldOrder -> String
show :: FieldOrder -> String
$cshowList :: [FieldOrder] -> ShowS
showList :: [FieldOrder] -> ShowS
Show)


defaultPPOpts :: PPOpts
defaultPPOpts :: PPOpts
defaultPPOpts = 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
                       , useFieldOrder :: FieldOrder
useFieldOrder = FieldOrder
DisplayOrder
                       }


-- 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 (OrigName -> 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
$cfrom :: forall x. NameDisp -> Rep NameDisp x
from :: forall x. NameDisp -> Rep NameDisp x
$cto :: forall x. Rep NameDisp x -> NameDisp
to :: forall x. Rep NameDisp x -> NameDisp
Generic, NameDisp -> ()
(NameDisp -> ()) -> NFData NameDisp
forall a. (a -> ()) -> NFData a
$crnf :: NameDisp -> ()
rnf :: NameDisp -> ()
NFData)

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

instance Semigroup NameDisp where
  NameDisp OrigName -> Maybe NameFormat
f    <> :: NameDisp -> NameDisp -> NameDisp
<> NameDisp OrigName -> Maybe NameFormat
g    = (OrigName -> Maybe NameFormat) -> NameDisp
NameDisp (\OrigName
n -> OrigName -> Maybe NameFormat
f OrigName
n Maybe NameFormat -> Maybe NameFormat -> Maybe NameFormat
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` OrigName -> Maybe NameFormat
g OrigName
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
(<>)

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
$cshowsPrec :: Int -> NameFormat -> ShowS
showsPrec :: Int -> NameFormat -> ShowS
$cshow :: NameFormat -> String
show :: NameFormat -> String
$cshowList :: [NameFormat] -> ShowS
showList :: [NameFormat] -> ShowS
Show)

-- | Never qualify names from this module.
neverQualifyMod :: ModPath -> NameDisp
neverQualifyMod :: ModPath -> NameDisp
neverQualifyMod ModPath
mn = (OrigName -> Maybe NameFormat) -> NameDisp
NameDisp ((OrigName -> Maybe NameFormat) -> NameDisp)
-> (OrigName -> Maybe NameFormat) -> NameDisp
forall a b. (a -> b) -> a -> b
$ \OrigName
n ->
  case OrigName -> OrigSource
ogSource OrigName
n of
    OrigSource
FromDefinition | OrigName -> ModPath
ogModule OrigName
n ModPath -> ModPath -> Bool
forall a. Eq a => a -> a -> Bool
== ModPath
mn -> NameFormat -> Maybe NameFormat
forall a. a -> Maybe a
Just NameFormat
UnQualified
    OrigSource
_ -> Maybe NameFormat
forall a. Maybe a
Nothing

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


-- | 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.
getNameFormat :: OrigName -> NameDisp -> NameFormat
getNameFormat :: OrigName -> NameDisp -> NameFormat
getNameFormat OrigName
m (NameDisp OrigName -> Maybe NameFormat
f)  = NameFormat -> Maybe NameFormat -> NameFormat
forall a. a -> Maybe a -> a
fromMaybe NameFormat
NotInScope (OrigName -> Maybe NameFormat
f OrigName
m)
getNameFormat OrigName
_ 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 = (PPCfg -> Doc) -> Doc
withPPCfg (NameDisp -> Doc
k (NameDisp -> Doc) -> (PPCfg -> NameDisp) -> PPCfg -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PPCfg -> NameDisp
ppcfgNameDisp)

-- | Produce a document in the context of the current configuration.
withPPCfg :: (PPCfg -> Doc) -> Doc
withPPCfg :: (PPCfg -> Doc) -> Doc
withPPCfg PPCfg -> Doc
k = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
cfg -> PPCfg -> Doc -> Doc Void
runDocWith PPCfg
cfg (PPCfg -> Doc
k PPCfg
cfg))

-- | Fix the way that names are displayed inside of a doc.
fixNameDisp :: NameDisp -> Doc -> Doc
fixNameDisp :: NameDisp -> Doc -> Doc
fixNameDisp NameDisp
disp Doc
d =
  (PPCfg -> Doc) -> Doc
withPPCfg (\PPCfg
cfg -> PPCfg -> Doc -> Doc
fixPPCfg PPCfg
cfg { ppcfgNameDisp = disp } Doc
d)

-- | Fix the way that names are displayed inside of a doc.
fixPPCfg :: PPCfg -> Doc -> Doc
fixPPCfg :: PPCfg -> Doc -> Doc
fixPPCfg PPCfg
cfg (Doc PPCfg -> Doc Void
f) = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
_ -> PPCfg -> Doc Void
f PPCfg
cfg)

updPPCfg :: (PPCfg -> PPCfg) -> Doc -> Doc
updPPCfg :: (PPCfg -> PPCfg) -> Doc -> Doc
updPPCfg PPCfg -> PPCfg
f Doc
d = (PPCfg -> Doc) -> Doc
withPPCfg (\PPCfg
cfg -> PPCfg -> Doc -> Doc
fixPPCfg (PPCfg -> PPCfg
f PPCfg
cfg) Doc
d)

debugShowUniques :: Doc -> Doc
debugShowUniques :: Doc -> Doc
debugShowUniques = (PPCfg -> PPCfg) -> Doc -> Doc
updPPCfg \PPCfg
cfg -> PPCfg
cfg { ppcfgShowNameUniques = True }




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

data PPCfg = PPCfg
  { PPCfg -> NameDisp
ppcfgNameDisp     :: NameDisp
  , PPCfg -> Bool
ppcfgShowNameUniques :: Bool
  }

defaultPPCfg :: PPCfg
defaultPPCfg :: PPCfg
defaultPPCfg = PPCfg
  { ppcfgNameDisp :: NameDisp
ppcfgNameDisp = NameDisp
forall a. Monoid a => a
mempty
  , ppcfgShowNameUniques :: Bool
ppcfgShowNameUniques = Bool
False
  }

newtype Doc = Doc (PPCfg -> PP.Doc Void) 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
$cfrom :: forall x. Doc -> Rep Doc x
from :: forall x. Doc -> Rep Doc x
$cto :: forall x. Rep Doc x -> Doc
to :: forall x. Rep Doc x -> Doc
Generic, Doc -> ()
(Doc -> ()) -> NFData Doc
forall a. (a -> ()) -> NFData a
$crnf :: Doc -> ()
rnf :: Doc -> ()
NFData)

instance Semigroup Doc where
  <> :: Doc -> Doc -> Doc
(<>) = (Doc Void -> Doc Void -> Doc Void) -> Doc -> Doc -> Doc
liftPP2 Doc Void -> Doc Void -> Doc Void
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid Doc where
  mempty :: Doc
mempty = Doc Void -> Doc
liftPP Doc Void
forall a. Monoid a => a
mempty
  mappend :: Doc -> Doc -> Doc
mappend = Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(<>)

runDocWith :: PPCfg -> Doc -> PP.Doc Void
runDocWith :: PPCfg -> Doc -> Doc Void
runDocWith PPCfg
names (Doc PPCfg -> Doc Void
f) = PPCfg -> Doc Void
f PPCfg
names

runDoc :: NameDisp -> Doc -> PP.Doc Void
runDoc :: NameDisp -> Doc -> Doc Void
runDoc NameDisp
disp = PPCfg -> Doc -> Doc Void
runDocWith PPCfg
defaultPPCfg { ppcfgNameDisp = disp }

instance Show Doc where
  show :: Doc -> String
show Doc
d = SimpleDocStream Void -> String
forall ann. SimpleDocStream ann -> String
PP.renderString (LayoutOptions -> Doc Void -> SimpleDocStream Void
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
opts (PPCfg -> Doc -> Doc Void
runDocWith PPCfg
defaultPPCfg Doc
d))
    where opts :: LayoutOptions
opts = LayoutOptions
PP.defaultLayoutOptions
                    { PP.layoutPageWidth = PP.AvailablePerLine 100 0.666 }

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

renderOneLine :: Doc -> String
renderOneLine :: Doc -> String
renderOneLine Doc
d = SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
PP.renderString (Doc Void -> SimpleDocStream Any
forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
PP.layoutCompact (PPCfg -> Doc -> Doc Void
runDocWith PPCfg
defaultPPCfg 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

instance PPName ModName where
  ppNameFixity :: ModName -> Maybe Fixity
ppNameFixity ModName
_ = Maybe Fixity
forall a. Maybe a
Nothing
  ppPrefixName :: ModName -> Doc
ppPrefixName   = ModName -> Doc
forall a. PP a => a -> Doc
pp
  ppInfixName :: ModName -> Doc
ppInfixName    = ModName -> Doc
forall a. PP a => a -> Doc
pp

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

pretty :: PP a => a -> String
pretty :: forall a. PP a => 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         = Int -> Doc -> Doc
nest Int
1 (Doc -> Doc
parens Doc
body)
                 | Bool
otherwise = Doc
body


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

-- | 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 :: 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
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 :: forall a. (Integral a, Show a, Eq a) => 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 :: forall a. (Integral a, Eq a) => 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 ---------------------------------------------------------

liftPP :: PP.Doc Void -> Doc
liftPP :: Doc Void -> Doc
liftPP Doc Void
d = (PPCfg -> Doc Void) -> Doc
Doc (Doc Void -> PPCfg -> Doc Void
forall a b. a -> b -> a
const Doc Void
d)

liftPP1 :: (PP.Doc Void -> PP.Doc Void) -> Doc -> Doc
liftPP1 :: (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 Doc Void -> Doc Void
f (Doc PPCfg -> Doc Void
d) = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
env -> Doc Void -> Doc Void
f (PPCfg -> Doc Void
d PPCfg
env))

liftPP2 :: (PP.Doc Void -> PP.Doc Void -> PP.Doc Void) -> (Doc -> Doc -> Doc)
liftPP2 :: (Doc Void -> Doc Void -> Doc Void) -> Doc -> Doc -> Doc
liftPP2 Doc Void -> Doc Void -> Doc Void
f (Doc PPCfg -> Doc Void
a) (Doc PPCfg -> Doc Void
b) = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
e -> Doc Void -> Doc Void -> Doc Void
f (PPCfg -> Doc Void
a PPCfg
e) (PPCfg -> Doc Void
b PPCfg
e))

liftSep :: ([PP.Doc Void] -> PP.Doc Void) -> ([Doc] -> Doc)
liftSep :: ([Doc Void] -> Doc Void) -> [Doc] -> Doc
liftSep [Doc Void] -> Doc Void
f [Doc]
ds = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
e -> [Doc Void] -> Doc Void
f [ PPCfg -> Doc Void
d PPCfg
e | Doc PPCfg -> Doc Void
d <- [Doc]
ds ])

reflow :: T.Text -> Doc
reflow :: Text -> Doc
reflow Text
x = Doc Void -> Doc
liftPP (Text -> Doc Void
forall ann. Text -> Doc ann
PP.reflow Text
x)

infixl 6 <.>, <+>, </>

(<.>) :: Doc -> Doc -> Doc
<.> :: Doc -> Doc -> Doc
(<.>)  = (Doc Void -> Doc Void -> Doc Void) -> Doc -> Doc -> Doc
liftPP2 Doc Void -> Doc Void -> Doc Void
forall a. Semigroup a => a -> a -> a
(PP.<>)

(<+>) :: Doc -> Doc -> Doc
<+> :: Doc -> Doc -> Doc
(<+>)  = (Doc Void -> Doc Void -> Doc Void) -> Doc -> Doc -> Doc
liftPP2 Doc Void -> Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann -> Doc ann
(PP.<+>)

(</>) :: Doc -> Doc -> Doc
Doc PPCfg -> Doc Void
x </> :: Doc -> Doc -> Doc
</> Doc PPCfg -> Doc Void
y = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
e -> PPCfg -> Doc Void
x PPCfg
e Doc Void -> Doc Void -> Doc Void
forall a. Semigroup a => a -> a -> a
<> Doc Void
forall ann. Doc ann
PP.softline Doc Void -> Doc Void -> Doc Void
forall a. Semigroup a => a -> a -> a
<> PPCfg -> Doc Void
y PPCfg
e)

infixl 5 $$

($$) :: Doc -> Doc -> Doc
$$ :: Doc -> Doc -> Doc
($$) Doc
x Doc
y = [Doc] -> Doc
vsep [Doc
x,Doc
y]

sep :: [Doc] -> Doc
sep :: [Doc] -> Doc
sep  = ([Doc Void] -> Doc Void) -> [Doc] -> Doc
liftSep [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.sep

fsep :: [Doc] -> Doc
fsep :: [Doc] -> Doc
fsep  = ([Doc Void] -> Doc Void) -> [Doc] -> Doc
liftSep [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.fillSep

hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep  = ([Doc Void] -> Doc Void) -> [Doc] -> Doc
liftSep [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.hsep

hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat  = ([Doc Void] -> Doc Void) -> [Doc] -> Doc
liftSep [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.hcat

vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat  = ([Doc Void] -> Doc Void) -> [Doc] -> Doc
liftSep [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.vcat

vsep :: [Doc] -> Doc
vsep :: [Doc] -> Doc
vsep  = ([Doc Void] -> Doc Void) -> [Doc] -> Doc
liftSep [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.vsep

group :: Doc -> Doc
group :: Doc -> Doc
group = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
PP.group

-- NB, this is the semantics of "hang" as defined
--  by the HugesPJ printer, not the "hang" from prettyprinter,
--  which is subtly different.
hang :: Doc -> Int -> Doc -> Doc
hang :: Doc -> Int -> Doc -> Doc
hang (Doc PPCfg -> Doc Void
p) Int
i (Doc PPCfg -> Doc Void
q) = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
e -> Int -> Doc Void -> Doc Void
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
i ([Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.vsep [PPCfg -> Doc Void
p PPCfg
e, PPCfg -> Doc Void
q PPCfg
e]))

nest :: Int -> Doc -> Doc
nest :: Int -> Doc -> Doc
nest Int
n = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 (Int -> Doc Void -> Doc Void
forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
n)

indent :: Int -> Doc -> Doc
indent :: Int -> Doc -> Doc
indent Int
n = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 (Int -> Doc Void -> Doc Void
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
n)

align :: Doc -> Doc
align :: Doc -> Doc
align = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
PP.align

parens :: Doc -> Doc
parens :: Doc -> Doc
parens  = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
PP.parens

braces :: Doc -> Doc
braces :: Doc -> Doc
braces  = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
PP.braces

brackets :: Doc -> Doc
brackets :: Doc -> Doc
brackets  = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
PP.brackets

quotes :: Doc -> Doc
quotes :: Doc -> Doc
quotes  = (Doc Void -> Doc Void) -> Doc -> Doc
liftPP1 Doc Void -> Doc Void
forall ann. Doc ann -> Doc ann
PP.squotes

commaSep :: [Doc] -> Doc
commaSep :: [Doc] -> Doc
commaSep [Doc]
xs = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
e -> [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
PP.sep (Doc Void -> [Doc Void] -> [Doc Void]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
PP.punctuate Doc Void
forall ann. Doc ann
PP.comma [ PPCfg -> Doc Void
d PPCfg
e | Doc PPCfg -> Doc Void
d <- [Doc]
xs ]))

-- | Print a comma-separated list. Lay out each item on a single line
-- if it will fit. If an item requires multiple lines, then start it
-- on its own line.
commaSepFill :: [Doc] -> Doc
commaSepFill :: [Doc] -> Doc
commaSepFill [Doc]
xs = (PPCfg -> Doc Void) -> Doc
Doc (\PPCfg
e -> [Doc Void] -> Doc Void
forall ann. [Doc ann] -> Doc ann
fillSep (Doc Void -> [Doc Void] -> [Doc Void]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
PP.punctuate Doc Void
forall ann. Doc ann
PP.comma [ PPCfg -> Doc Void
d PPCfg
e | Doc PPCfg -> Doc Void
d <- [Doc]
xs ]))
  where
    fillSep :: [Doc ann] -> Doc ann
fillSep [] = Doc ann
forall a. Monoid a => a
mempty
    fillSep (Doc ann
d0 : [Doc ann]
ds) = (Doc ann -> Doc ann -> Doc ann) -> Doc ann -> [Doc ann] -> Doc ann
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Doc ann
a Doc ann
d -> Doc ann
a Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.group (Doc ann
forall ann. Doc ann
PP.line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d)) Doc ann
d0 [Doc ann]
ds

ppList :: [Doc] -> Doc
ppList :: [Doc] -> Doc
ppList [Doc]
xs = Doc -> Doc
group (Int -> Doc -> Doc
nest Int
1 (Doc -> Doc
brackets ([Doc] -> Doc
commaSepFill [Doc]
xs)))

ppTuple :: [Doc] -> Doc
ppTuple :: [Doc] -> Doc
ppTuple [Doc]
xs = Doc -> Doc
group (Int -> Doc -> Doc
nest Int
1 (Doc -> Doc
parens ([Doc] -> Doc
commaSep [Doc]
xs)))

ppRecord :: [Doc] -> Doc
ppRecord :: [Doc] -> Doc
ppRecord [Doc]
xs = Doc -> Doc
group (Int -> Doc -> Doc
nest Int
1 (Doc -> Doc
braces ([Doc] -> Doc
commaSep [Doc]
xs)))

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

text :: String -> Doc
text :: String -> Doc
text String
s = Doc Void -> Doc
liftPP (String -> Doc Void
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty String
s)

char :: Char -> Doc
char :: Char -> Doc
char Char
c = Doc Void -> Doc
liftPP (Char -> Doc Void
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Char
c)

integer :: Integer -> Doc
integer :: Integer -> Doc
integer Integer
i = Doc Void -> Doc
liftPP (Integer -> Doc Void
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Integer
i)

int :: Int -> Doc
int :: Int -> Doc
int Int
i = Doc Void -> Doc
liftPP (Int -> Doc Void
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Int
i)

comma :: Doc
comma :: Doc
comma  = Doc Void -> Doc
liftPP Doc Void
forall ann. Doc ann
PP.comma

colon :: Doc
colon :: Doc
colon  = Doc Void -> Doc
liftPP Doc Void
forall ann. Doc ann
PP.colon

pipe :: Doc
pipe :: Doc
pipe = Doc Void -> Doc
liftPP Doc Void
forall ann. Doc ann
PP.pipe


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

instance PP ModPath where
  ppPrec :: Int -> ModPath -> Doc
ppPrec Int
_ ModPath
p =
    case ModPath
p of
      TopModule ModName
m -> ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
m
      Nested ModPath
q Ident
t  -> ModPath -> Doc
forall a. PP a => a -> Doc
pp ModPath
q Doc -> Doc -> Doc
<.> Doc
"::" Doc -> Doc -> Doc
<.> Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
t

instance PP OrigName where
  ppPrec :: Int -> OrigName -> Doc
ppPrec Int
_ OrigName
og =
    (NameDisp -> Doc) -> Doc
withNameDisp ((NameDisp -> Doc) -> Doc) -> (NameDisp -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ \NameDisp
disp ->
      case OrigName -> NameDisp -> NameFormat
getNameFormat OrigName
og NameDisp
disp of
        NameFormat
UnQualified -> Ident -> Doc
forall a. PP a => a -> Doc
pp (OrigName -> Ident
ogName OrigName
og)
        Qualified ModName
m -> ModPath -> Doc -> Doc
ppQual (ModName -> ModPath
TopModule ModName
m) (Ident -> Doc
forall a. PP a => a -> Doc
pp (OrigName -> Ident
ogName OrigName
og))
        NameFormat
NotInScope  -> ModPath -> Doc -> Doc
ppQual (OrigName -> ModPath
ogModule OrigName
og)
                       case OrigName -> Maybe Ident
ogFromParam OrigName
og of
                         Just Ident
x  -> Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
x Doc -> Doc -> Doc
<.> Doc
"::" Doc -> Doc -> Doc
<.> Ident -> Doc
forall a. PP a => a -> Doc
pp (OrigName -> Ident
ogName OrigName
og)
                         Maybe Ident
Nothing -> Ident -> Doc
forall a. PP a => a -> Doc
pp (OrigName -> Ident
ogName OrigName
og)
    where
    ppQual :: ModPath -> Doc -> Doc
ppQual ModPath
mo Doc
x =
      case ModPath
mo of
        TopModule ModName
m
          | ModName
m ModName -> ModName -> Bool
forall a. Eq a => a -> a -> Bool
== ModName
exprModName -> Doc
x
          | Bool
otherwise -> ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
m Doc -> Doc -> Doc
<.> Doc
"::" Doc -> Doc -> Doc
<.> Doc
x
        Nested ModPath
m Ident
y -> ModPath -> Doc -> Doc
ppQual ModPath
m (Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
y Doc -> Doc -> Doc
<.> Doc
"::" Doc -> Doc -> Doc
<.> Doc
x)

instance PP Namespace where
  ppPrec :: Int -> Namespace -> Doc
ppPrec Int
_ Namespace
ns =
    case Namespace
ns of
      Namespace
NSValue     -> Doc
"/*value*/"
      Namespace
NSConstructor -> Doc
"/*constructor*/"
      Namespace
NSType      -> Doc
"/*type*/"
      Namespace
NSModule    -> Doc
"/*module*/"

instance PP PrimIdent where
  ppPrec :: Int -> PrimIdent -> Doc
ppPrec Int
_ (PrimIdent ModName
m Text
t) = ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
m Doc -> Doc -> Doc
<.> String -> Doc
text (Text -> String
T.unpack Text
t)