{-# LANGUAGE CPP                #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}

module Language.Fixpoint.Types.PrettyPrint where

import           Debug.Trace               (trace)
import           Text.PrettyPrint.HughesPJ.Compat
import qualified Text.PrettyPrint.Boxes as B
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet        as S
import qualified Data.List           as L
import           Language.Fixpoint.Misc
import           Data.Hashable
import qualified Data.Text as T

traceFix     ::  (Fixpoint a) => String -> a -> a
traceFix :: forall a. Fixpoint a => String -> a -> a
traceFix String
s a
x = forall a. String -> a -> a
trace (String
"\nTrace: [" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"] : " forall a. [a] -> [a] -> [a]
++ forall a. Fixpoint a => a -> String
showFix a
x) a
x

------------------------------------------------------------------
class Fixpoint a where
  toFix    :: a -> Doc
  simplify :: a -> a
  simplify =  forall a. a -> a
id

showFix :: (Fixpoint a) => a -> String
showFix :: forall a. Fixpoint a => a -> String
showFix =  Doc -> String
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fixpoint a => a -> Doc
toFix

instance (Ord a, Hashable a, Fixpoint a) => Fixpoint (S.HashSet a) where
  toFix :: HashSet a -> Doc
toFix HashSet a
xs = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
";" (forall a. Fixpoint a => a -> Doc
toFix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> [a]
L.sort (forall a. HashSet a -> [a]
S.toList HashSet a
xs))
  simplify :: HashSet a -> HashSet a
simplify = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Fixpoint a => a -> a
simplify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashSet a -> [a]
S.toList

instance Fixpoint () where
  toFix :: () -> Doc
toFix ()
_ = Doc
"()"

instance Fixpoint a => Fixpoint (Maybe a) where
  toFix :: Maybe a -> Doc
toFix    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"Nothing" ((Doc
"Just" Doc -> Doc -> Doc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fixpoint a => a -> Doc
toFix)
  simplify :: Maybe a -> Maybe a
simplify = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Fixpoint a => a -> a
simplify

instance Fixpoint a => Fixpoint [a] where
  toFix :: [a] -> Doc
toFix [a]
xs = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
";" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Fixpoint a => a -> Doc
toFix [a]
xs)
  simplify :: [a] -> [a]
simplify = forall a b. (a -> b) -> [a] -> [b]
map forall a. Fixpoint a => a -> a
simplify

instance (Fixpoint a, Fixpoint b) => Fixpoint (a,b) where
  toFix :: (a, b) -> Doc
toFix   (a
x,b
y)  = forall a. Fixpoint a => a -> Doc
toFix a
x Doc -> Doc -> Doc
<+> Doc
":" Doc -> Doc -> Doc
<+> forall a. Fixpoint a => a -> Doc
toFix b
y
  simplify :: (a, b) -> (a, b)
simplify (a
x,b
y) = (forall a. Fixpoint a => a -> a
simplify a
x, forall a. Fixpoint a => a -> a
simplify b
y)

instance (Fixpoint a, Fixpoint b, Fixpoint c) => Fixpoint (a,b,c) where
  toFix :: (a, b, c) -> Doc
toFix   (a
x,b
y,c
z)  = forall a. Fixpoint a => a -> Doc
toFix a
x Doc -> Doc -> Doc
<+> Doc
":" Doc -> Doc -> Doc
<+> forall a. Fixpoint a => a -> Doc
toFix b
y Doc -> Doc -> Doc
<+> Doc
":" Doc -> Doc -> Doc
<+> forall a. Fixpoint a => a -> Doc
toFix  c
z
  simplify :: (a, b, c) -> (a, b, c)
simplify (a
x,b
y,c
z) = (forall a. Fixpoint a => a -> a
simplify a
x, forall a. Fixpoint a => a -> a
simplify b
y,forall a. Fixpoint a => a -> a
simplify c
z)

instance Fixpoint Bool where
  toFix :: Bool -> Doc
toFix Bool
True  = Doc
"True"
  toFix Bool
False = Doc
"False"
  simplify :: Bool -> Bool
simplify Bool
z  = Bool
z

instance Fixpoint Int where
  toFix :: Int -> Doc
toFix = forall a. Show a => a -> Doc
tshow

instance Fixpoint Integer where
  toFix :: Integer -> Doc
toFix = Integer -> Doc
integer

instance Fixpoint Double where
  toFix :: Double -> Doc
toFix = Double -> Doc
double

------------------------------------------------------------------
data Tidy = Lossy | Full deriving (Tidy -> Tidy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tidy -> Tidy -> Bool
$c/= :: Tidy -> Tidy -> Bool
== :: Tidy -> Tidy -> Bool
$c== :: Tidy -> Tidy -> Bool
Eq, Eq Tidy
Tidy -> Tidy -> Bool
Tidy -> Tidy -> Ordering
Tidy -> Tidy -> Tidy
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
min :: Tidy -> Tidy -> Tidy
$cmin :: Tidy -> Tidy -> Tidy
max :: Tidy -> Tidy -> Tidy
$cmax :: Tidy -> Tidy -> Tidy
>= :: Tidy -> Tidy -> Bool
$c>= :: Tidy -> Tidy -> Bool
> :: Tidy -> Tidy -> Bool
$c> :: Tidy -> Tidy -> Bool
<= :: Tidy -> Tidy -> Bool
$c<= :: Tidy -> Tidy -> Bool
< :: Tidy -> Tidy -> Bool
$c< :: Tidy -> Tidy -> Bool
compare :: Tidy -> Tidy -> Ordering
$ccompare :: Tidy -> Tidy -> Ordering
Ord)

-- | Implement either `pprintTidy` or `pprintPrec`
class PPrint a where

  pprintTidy :: Tidy -> a -> Doc
  pprintTidy = forall a. PPrint a => Int -> Tidy -> a -> Doc
pprintPrec Int
0

  pprintPrec :: Int -> Tidy -> a -> Doc
  pprintPrec Int
_ = forall a. PPrint a => Tidy -> a -> Doc
pprintTidy

-- | Top-level pretty printer
pprint :: (PPrint a) => a -> Doc
pprint :: forall a. PPrint a => a -> Doc
pprint = forall a. PPrint a => Int -> Tidy -> a -> Doc
pprintPrec Int
0 Tidy
Full

showpp :: (PPrint a) => a -> String
showpp :: forall a. PPrint a => a -> String
showpp = Doc -> String
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PPrint a => a -> Doc
pprint

showTable :: (PPrint k, PPrint v) => Tidy -> [(k, v)] -> String
showTable :: forall k v. (PPrint k, PPrint v) => Tidy -> [(k, v)] -> String
showTable Tidy
k = Doc -> String
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc
pprintKVs Tidy
k

-- | Please do not alter this.
tracepp :: (PPrint a) => String -> a -> a
tracepp :: forall a. PPrint a => String -> a -> a
tracepp String
s a
x = forall a. String -> a -> a
trace (String
"\nTrace: [" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"] : " forall a. [a] -> [a] -> [a]
++ forall a. PPrint a => a -> String
showpp a
x) a
x

notracepp :: (PPrint a) => String -> a -> a
notracepp :: forall a. PPrint a => String -> a -> a
notracepp String
_ a
x = a
x


instance PPrint Doc where
  pprintTidy :: Tidy -> Doc -> Doc
pprintTidy Tidy
_ = forall a. a -> a
id

instance (PPrint a, PPrint b) => PPrint (Either a b) where
  pprintTidy :: Tidy -> Either a b -> Doc
pprintTidy Tidy
k (Left  a
a) = Doc
"Left"  Doc -> Doc -> Doc
<+> forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k a
a
  pprintTidy Tidy
k (Right b
b) = Doc
"Right" Doc -> Doc -> Doc
<+> forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k b
b

instance PPrint a => PPrint (Maybe a) where
  pprintTidy :: Tidy -> Maybe a -> Doc
pprintTidy Tidy
k = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"Nothing" ((Doc
"Just" Doc -> Doc -> Doc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k)

instance PPrint a => PPrint [a] where
  pprintTidy :: Tidy -> [a] -> Doc
pprintTidy Tidy
k = Doc -> Doc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k)

instance (Ord a, PPrint a) => PPrint (S.HashSet a) where
  pprintTidy :: Tidy -> HashSet a -> Doc
pprintTidy Tidy
k = forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
L.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashSet a -> [a]
S.toList

instance (Ord a, PPrint a, PPrint b) => PPrint (M.HashMap a b) where
  pprintTidy :: Tidy -> HashMap a b -> Doc
pprintTidy Tidy
k = forall k v. (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc
pprintKVs Tidy
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ord a => HashMap a b -> [(a, b)]
hashMapToAscList

instance PPrint Char where
  pprintTidy :: Tidy -> Char -> Doc
pprintTidy Tidy
_ = Char -> Doc
char


pprintKVs   :: (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc
pprintKVs :: forall k v. (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc
pprintKVs Tidy
t = [Doc] -> Doc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (PPrint a, PPrint a) => (a, a) -> Doc
pp1
  where
    pp1 :: (a, a) -> Doc
pp1 (a
x,a
y) = forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
t a
x Doc -> Doc -> Doc
<+> Doc
":=" Doc -> Doc -> Doc
<+> forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
t a
y

instance (PPrint a, PPrint b, PPrint c) => PPrint (a, b, c) where
  pprintTidy :: Tidy -> (a, b, c) -> Doc
pprintTidy Tidy
k (a
x, b
y, c
z)  = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k a
x Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                     forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k b
y Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                     forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k c
z



instance (PPrint a, PPrint b, PPrint c, PPrint d) => PPrint (a, b, c, d) where
  pprintTidy :: Tidy -> (a, b, c, d) -> Doc
pprintTidy Tidy
k (a
w, b
x, c
y, d
z)  = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k a
w Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                        forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k b
x Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                        forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k c
y Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                        forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k d
z

instance (PPrint a, PPrint b, PPrint c, PPrint d, PPrint e) => PPrint (a, b, c, d, e) where
  pprintTidy :: Tidy -> (a, b, c, d, e) -> Doc
pprintTidy Tidy
k (a
v, b
w, c
x, d
y, e
z)  = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k a
v Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                           forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k b
w Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                           forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k c
x Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                           forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k d
y Doc -> Doc -> Doc
<-> Doc
"," Doc -> Doc -> Doc
<+>
                                           forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k e
z



instance (PPrint a, PPrint b) => PPrint (a,b) where
  pprintTidy :: Tidy -> (a, b) -> Doc
pprintTidy Tidy
k (a
x, b
y)  = forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k a
x Doc -> Doc -> Doc
<+> Doc
":" Doc -> Doc -> Doc
<+> forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k b
y

instance PPrint Bool where
  pprintTidy :: Tidy -> Bool -> Doc
pprintTidy Tidy
_ = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance PPrint Float where
  pprintTidy :: Tidy -> Float -> Doc
pprintTidy Tidy
_ = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance PPrint () where
  pprintTidy :: Tidy -> () -> Doc
pprintTidy Tidy
_ = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

#if !(defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)))
instance PPrint String where
  pprintTidy _ = text
#endif

instance PPrint Int where
  pprintTidy :: Tidy -> Int -> Doc
pprintTidy Tidy
_ = forall a. Show a => a -> Doc
tshow

instance PPrint Integer where
  pprintTidy :: Tidy -> Integer -> Doc
pprintTidy Tidy
_ = Integer -> Doc
integer

instance PPrint T.Text where
  pprintTidy :: Tidy -> Text -> Doc
pprintTidy Tidy
_ = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

newtype DocTable = DocTable [(Doc, Doc)]

instance Semigroup DocTable where
  DocTable [(Doc, Doc)]
t1 <> :: DocTable -> DocTable -> DocTable
<> DocTable [(Doc, Doc)]
t2 = [(Doc, Doc)] -> DocTable
DocTable ([(Doc, Doc)]
t1 forall a. [a] -> [a] -> [a]
++ [(Doc, Doc)]
t2)

instance Monoid DocTable where
  mempty :: DocTable
mempty  = [(Doc, Doc)] -> DocTable
DocTable []
  mappend :: DocTable -> DocTable -> DocTable
mappend = forall a. Semigroup a => a -> a -> a
(<>)

class PTable a where
  ptable :: a -> DocTable

instance PPrint DocTable where
  pprintTidy :: Tidy -> DocTable -> Doc
pprintTidy Tidy
_ (DocTable [(Doc, Doc)]
kvs) = Box -> Doc
boxDoc forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
B.hsep Int
1 Alignment
B.left [Box
ks', Box
cs', Box
vs']
    where
      ([Doc]
ks, [Doc]
vs)                = forall a b. [(a, b)] -> ([a], [b])
unzip [(Doc, Doc)]
kvs
      n :: Int
n                       = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Doc, Doc)]
kvs
      ks' :: Box
ks'                     = forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
B.vcat Alignment
B.left  forall a b. (a -> b) -> a -> b
$ Doc -> Box
docBox forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc]
ks
      vs' :: Box
vs'                     = forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
B.vcat Alignment
B.right forall a b. (a -> b) -> a -> b
$ Doc -> Box
docBox forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc]
vs
      cs' :: Box
cs'                     = forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
B.vcat Alignment
B.left  forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n forall a b. (a -> b) -> a -> b
$ String -> Box
B.text String
":"

boxHSep :: Doc -> Doc -> Doc
boxHSep :: Doc -> Doc -> Doc
boxHSep Doc
d1 Doc
d2 = Box -> Doc
boxDoc forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
B.hcat Alignment
B.top [Doc -> Box
docBox Doc
d1, Doc -> Box
docBox Doc
d2]

boxDoc :: B.Box -> Doc
boxDoc :: Box -> Doc
boxDoc = String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> String
B.render

docBox :: Doc -> B.Box
docBox :: Doc -> Box
docBox = String -> Box
B.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render