{-# 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
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)
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
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 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
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))
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)
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
ppNameFixity :: a -> Maybe Fixity
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 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
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 -> Fixity
ieFixity :: 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
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 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
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)
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
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