{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Utils.PP where
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
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>"
instance S.Semigroup NameDisp where
NameDisp f :: ModName -> Ident -> Maybe NameFormat
f <> :: NameDisp -> NameDisp -> NameDisp
<> NameDisp g :: ModName -> Ident -> Maybe NameFormat
g = (ModName -> Ident -> Maybe NameFormat) -> NameDisp
NameDisp (\m :: ModName
m n :: 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)
EmptyNameDisp <> EmptyNameDisp = NameDisp
EmptyNameDisp
EmptyNameDisp <> x :: NameDisp
x = NameDisp
x
x :: NameDisp
x <> _ = 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)
neverQualifyMod :: ModName -> NameDisp
neverQualifyMod :: ModName -> NameDisp
neverQualifyMod mn :: 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
$ \ mn' :: ModName
mn' _ ->
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
$ \ mn :: ModName
mn _ -> 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
$ \ _ _ -> NameFormat -> Maybe NameFormat
forall a. a -> Maybe a
Just NameFormat
UnQualified
fmtModName :: ModName -> NameFormat -> T.Text
fmtModName :: ModName -> NameFormat -> Text
fmtModName _ UnQualified = Text
T.empty
fmtModName _ (Qualified mn :: ModName
mn) = ModName -> Text
modNameToText ModName
mn
fmtModName mn :: ModName
mn NotInScope = ModName -> Text
modNameToText ModName
mn
extend :: NameDisp -> NameDisp -> NameDisp
extend :: NameDisp -> NameDisp -> NameDisp
extend = NameDisp -> NameDisp -> NameDisp
forall a. Monoid a => a -> a -> a
mappend
getNameFormat :: ModName -> Ident -> NameDisp -> NameFormat
getNameFormat :: ModName -> Ident -> NameDisp -> NameFormat
getNameFormat m :: ModName
m i :: Ident
i (NameDisp f :: 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 _ _ EmptyNameDisp = NameFormat
NotInScope
withNameDisp :: (NameDisp -> Doc) -> Doc
withNameDisp :: (NameDisp -> Doc) -> Doc
withNameDisp k :: NameDisp -> Doc
k = (NameDisp -> Doc) -> Doc
Doc (\disp :: NameDisp
disp -> NameDisp -> Doc -> Doc
runDoc NameDisp
disp (NameDisp -> Doc
k NameDisp
disp))
fixNameDisp :: NameDisp -> Doc -> Doc
fixNameDisp :: NameDisp -> Doc -> Doc
fixNameDisp disp :: NameDisp
disp (Doc f :: NameDisp -> Doc
f) = (NameDisp -> Doc) -> Doc
Doc (\ _ -> NameDisp -> Doc
f NameDisp
disp)
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 names :: NameDisp
names (Doc f :: NameDisp -> Doc
f) = NameDisp -> Doc
f NameDisp
names
instance Show Doc where
show :: Doc -> String
show d :: 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 d :: 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 d :: 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
ppNameFixity :: a -> Maybe (Assoc, Int)
ppPrefixName :: a -> Doc
ppInfixName :: a -> Doc
pp :: PP a => a -> Doc
pp :: a -> Doc
pp = Int -> a -> Doc
forall a. PP a => Int -> a -> Doc
ppPrec 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 b :: Bool
b body :: Doc
body | Bool
b = Doc -> Doc
parens Doc
body
| Bool
otherwise = Doc
body
data Assoc = LeftAssoc | RightAssoc | NonAssoc
deriving (Int -> Assoc -> ShowS
[Assoc] -> ShowS
Assoc -> String
(Int -> Assoc -> ShowS)
-> (Assoc -> String) -> ([Assoc] -> ShowS) -> Show Assoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assoc] -> ShowS
$cshowList :: [Assoc] -> ShowS
show :: Assoc -> String
$cshow :: Assoc -> String
showsPrec :: Int -> Assoc -> ShowS
$cshowsPrec :: Int -> Assoc -> ShowS
Show, Assoc -> Assoc -> Bool
(Assoc -> Assoc -> Bool) -> (Assoc -> Assoc -> Bool) -> Eq Assoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assoc -> Assoc -> Bool
$c/= :: Assoc -> Assoc -> Bool
== :: Assoc -> Assoc -> Bool
$c== :: Assoc -> Assoc -> Bool
Eq, (forall x. Assoc -> Rep Assoc x)
-> (forall x. Rep Assoc x -> Assoc) -> Generic Assoc
forall x. Rep Assoc x -> Assoc
forall x. Assoc -> Rep Assoc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Assoc x -> Assoc
$cfrom :: forall x. Assoc -> Rep Assoc x
Generic, Assoc -> ()
(Assoc -> ()) -> NFData Assoc
forall a. (a -> ()) -> NFData a
rnf :: Assoc -> ()
$crnf :: Assoc -> ()
NFData)
data Infix op thing = Infix
{ Infix op thing -> op
ieOp :: op
, Infix op thing -> thing
ieLeft :: thing
, Infix op thing -> thing
ieRight :: thing
, Infix op thing -> Int
iePrec :: Int
, Infix op thing -> Assoc
ieAssoc :: Assoc
}
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
ppInfix :: (PP thing, PP op)
=> Int
-> (thing -> Maybe (Infix op thing))
-> Infix op thing
-> Doc
ppInfix :: Int -> (thing -> Maybe (Infix op thing)) -> Infix op thing -> Doc
ppInfix lp :: Int
lp isInfix :: thing -> Maybe (Infix op thing)
isInfix expr :: Infix op thing
expr =
[Doc] -> Doc
sep [ (Int -> Bool) -> thing -> Doc
ppSub (Assoc -> Int -> Bool
wrapSub Assoc
LeftAssoc ) (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)
, (Int -> Bool) -> thing -> Doc
ppSub (Assoc -> Int -> Bool
wrapSub Assoc
RightAssoc) (Infix op thing -> thing
forall op thing. Infix op thing -> thing
ieRight Infix op thing
expr) ]
where
wrapSub :: Assoc -> Int -> Bool
wrapSub dir :: Assoc
dir p :: Int
p = Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Infix op thing -> Int
forall op thing. Infix op thing -> Int
iePrec Infix op thing
expr Bool -> Bool -> Bool
|| Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Infix op thing -> Int
forall op thing. Infix op thing -> Int
iePrec Infix op thing
expr Bool -> Bool -> Bool
&& Infix op thing -> Assoc
forall op thing. Infix op thing -> Assoc
ieAssoc Infix op thing
expr Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc
dir
ppSub :: (Int -> Bool) -> thing -> Doc
ppSub w :: Int -> Bool
w e :: thing
e
| Just e1 :: Infix op thing
e1 <- thing -> Maybe (Infix op thing)
isInfix thing
e = Bool -> Doc -> Doc
optParens (Int -> Bool
w (Infix op thing -> Int
forall op thing. Infix op thing -> Int
iePrec 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 _ e :: thing
e = Int -> thing -> Doc
forall a. PP a => Int -> a -> Doc
ppPrec Int
lp thing
e
ordinal :: (Integral a, Show a, Eq a) => a -> Doc
ordinal :: a -> Doc
ordinal x :: 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)
ordSuffix :: (Integral a, Eq a) => a -> String
ordSuffix :: a -> String
ordSuffix n0 :: a
n0 =
case a
n a -> a -> a
forall a. Integral a => a -> a -> a
`mod` 10 of
1 | Bool
notTeen -> "st"
2 | Bool
notTeen -> "nd"
3 | Bool
notTeen -> "rd"
_ -> "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` 100
notTeen :: Bool
notTeen = a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 11 Bool -> Bool -> Bool
|| a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 19
liftPJ :: PJ.Doc -> Doc
liftPJ :: Doc -> Doc
liftPJ d :: 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 f :: Doc -> Doc
f (Doc d :: NameDisp -> Doc
d) = (NameDisp -> Doc) -> Doc
Doc (\env :: 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 f :: Doc -> Doc -> Doc
f (Doc a :: NameDisp -> Doc
a) (Doc b :: NameDisp -> Doc
b) = (NameDisp -> Doc) -> Doc
Doc (\e :: 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 f :: [Doc] -> Doc
f ds :: [Doc]
ds = (NameDisp -> Doc) -> Doc
Doc (\e :: NameDisp
e -> [Doc] -> Doc
f [ NameDisp -> Doc
d NameDisp
e | Doc d :: 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 p :: NameDisp -> Doc
p) i :: Int
i (Doc q :: NameDisp -> Doc
q) = (NameDisp -> Doc) -> Doc
Doc (\e :: 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 n :: 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 d :: Doc
d = [Doc] -> Doc
hcat [ "`", Doc
d, "`" ]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p :: Doc
p = [Doc] -> [Doc]
go
where
go :: [Doc] -> [Doc]
go (d :: Doc
d:ds :: [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 s :: String
s = Doc -> Doc
liftPJ (String -> Doc
PJ.text String
s)
char :: Char -> Doc
char :: Char -> Doc
char c :: Char
c = Doc -> Doc
liftPJ (Char -> Doc
PJ.char Char
c)
integer :: Integer -> Doc
integer :: Integer -> Doc
integer i :: Integer
i = Doc -> Doc
liftPJ (Integer -> Doc
PJ.integer Integer
i)
int :: Int -> Doc
int :: Int -> Doc
int i :: 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 _ str :: Text
str = String -> Doc
text (Text -> String
T.unpack Text
str)
instance PP Ident where
ppPrec :: Int -> Ident -> Doc
ppPrec _ i :: Ident
i = String -> Doc
text (Text -> String
T.unpack (Ident -> Text
identText Ident
i))
instance PP ModName where
ppPrec :: Int -> ModName -> Doc
ppPrec _ = 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 _ LeftAssoc = String -> Doc
text "left-associative"
ppPrec _ RightAssoc = String -> Doc
text "right-associative"
ppPrec _ NonAssoc = String -> Doc
text "non-associative"