{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE EmptyCase                 #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE UndecidableInstances      #-}

{-|

Pretty printing for expressions.

-}
module Language.Expression.Pretty
  (
  -- * Classes
    Pretty(..)
  , prettys
  , Pretty1(..)
  , prettys1
  , Pretty2(..)
  , prettys2
  , Pretty3(..)
  , prettys3
  -- * Combinators
  , putPretty
  , prettys1PrecBinop
  , prettys1PrecUnop
  ) where

import           Data.Functor.Const
import           Data.List                  (intersperse)
import           Data.Monoid                (Endo (..))

import           Language.Expression
import           Language.Expression.Choice
import           Language.Expression.Scope

--------------------------------------------------------------------------------
--  Convenience
--------------------------------------------------------------------------------

putPretty :: Pretty a => a -> IO ()
putPretty :: a -> IO ()
putPretty = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Pretty a => a -> String
pretty

--------------------------------------------------------------------------------
--  Combinators
--------------------------------------------------------------------------------

prettys1PrecUnop :: Pretty1 t => Int -> String -> Int -> t a -> ShowS
prettys1PrecUnop :: Int -> String -> Int -> t a -> ShowS
prettys1PrecUnop Int
opPrec String
opStr Int
p t a
x =
  Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
opPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
opStr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec (Int
opPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) t a
x

prettys1PrecBinop
  :: (Pretty1 f, Pretty1 g)
  => Int -> String -> Int -> f a -> g b -> ShowS
prettys1PrecBinop :: Int -> String -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
opPrec String
opStr Int
p f a
x g b
y =
  Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
opPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
  Int -> f a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec (Int
opPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) f a
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
opStr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> g b -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec (Int
opPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) g b
y

--------------------------------------------------------------------------------
--  Pretty typeclasses
--------------------------------------------------------------------------------

prettys :: Pretty a => a -> ShowS
prettys :: a -> ShowS
prettys = Int -> a -> ShowS
forall a. Pretty a => Int -> a -> ShowS
prettysPrec Int
0

prettys1 :: Pretty1 t => t a -> ShowS
prettys1 :: t a -> ShowS
prettys1 = Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
0

prettys2 :: (Pretty2 op, Pretty1 t) => op t a -> ShowS
prettys2 :: op t a -> ShowS
prettys2 = Int -> op t a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
0

prettys3 :: (Pretty3 h, Pretty2 s, Pretty1 t) => h s t a -> ShowS
prettys3 :: h s t a -> ShowS
prettys3 = Int -> h s t a -> ShowS
forall k k k k (h :: ((k -> *) -> k -> *) -> (k -> *) -> k -> *)
       (s :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty3 h, Pretty2 s, Pretty1 t) =>
Int -> h s t a -> ShowS
prettys3Prec Int
0

class Pretty a where
  {-# MINIMAL pretty | prettysPrec #-}

  pretty :: a -> String
  prettysPrec :: Int -> a -> ShowS

  pretty a
x = a -> ShowS
forall a. Pretty a => a -> ShowS
prettys a
x String
""
  prettysPrec Int
_ a
x String
s = a -> String
forall a. Pretty a => a -> String
pretty a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

class Pretty1 t where
  {-# MINIMAL pretty1 | prettys1Prec #-}

  pretty1 :: t a -> String
  pretty1 t a
x = t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => t a -> ShowS
prettys1 t a
x String
""

  prettys1Prec :: Int -> t a -> ShowS
  prettys1Prec Int
_ t a
x String
s = t a -> String
forall k (t :: k -> *) (a :: k). Pretty1 t => t a -> String
pretty1 t a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

class Pretty2 op where
  {-# MINIMAL pretty2 | prettys2Prec #-}

  pretty2 :: (Pretty1 t) => op t a -> String
  pretty2 op t a
x = op t a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
op t a -> ShowS
prettys2 op t a
x String
""

  prettys2Prec :: (Pretty1 t) => Int -> op t a -> ShowS
  prettys2Prec Int
_ op t a
x String
s = op t a -> String
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
op t a -> String
pretty2 op t a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

class Pretty3 h where
  {-# MINIMAL pretty3 | prettys3Prec #-}

  pretty3 :: (Pretty2 s, Pretty1 t) => h s t a -> String
  pretty3 h s t a
x = h s t a -> ShowS
forall k k k k (h :: ((k -> *) -> k -> *) -> (k -> *) -> k -> *)
       (s :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty3 h, Pretty2 s, Pretty1 t) =>
h s t a -> ShowS
prettys3 h s t a
x String
""

  prettys3Prec :: (Pretty2 s, Pretty1 t) => Int -> h s t a -> ShowS
  prettys3Prec Int
_ h s t a
x String
s = h s t a -> String
forall k k k k (h :: ((k -> *) -> k -> *) -> (k -> *) -> k -> *)
       (s :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty3 h, Pretty2 s, Pretty1 t) =>
h s t a -> String
pretty3 h s t a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

--------------------------------------------------------------------------------
--  Combinatory instances
--------------------------------------------------------------------------------

instance {-# OVERLAPPABLE #-} (Pretty1 t) => Pretty (t a) where
  prettysPrec :: Int -> t a -> ShowS
prettysPrec = Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec

instance {-# OVERLAPPABLE #-} (Pretty2 f, Pretty1 t) => Pretty1 (f t) where
  prettys1Prec :: Int -> f t a -> ShowS
prettys1Prec = Int -> f t a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec

instance {-# OVERLAPPABLE #-} (Pretty3 h, Pretty2 s) => Pretty2 (h s) where
  prettys2Prec :: Int -> h s t a -> ShowS
prettys2Prec = Int -> h s t a -> ShowS
forall k k k k (h :: ((k -> *) -> k -> *) -> (k -> *) -> k -> *)
       (s :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty3 h, Pretty2 s, Pretty1 t) =>
Int -> h s t a -> ShowS
prettys3Prec

instance Pretty1 (Const String) where
  pretty1 :: Const String a -> String
pretty1 (Const String
x) = String
x

instance (Pretty2 op) => Pretty2 (HFree op) where
  prettys2Prec :: Int -> HFree op t a -> ShowS
prettys2Prec Int
p = \case
    HPure t a
x -> Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
p t a
x
    HWrap op (HFree op t) a
op -> Int -> op (HFree op t) a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
p op (HFree op t) a
op

instance (Pretty1 t) => Pretty2 (BV t) where
  prettys2Prec :: Int -> BV t t a -> ShowS
prettys2Prec Int
p = (t a -> ShowS) -> (t a -> ShowS) -> BV t t a -> ShowS
forall k (w :: k -> *) (a :: k) r (v :: k -> *).
(w a -> r) -> (v a -> r) -> BV w v a -> r
foldBV (Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
p) (Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
p)

instance (Pretty2 h, Pretty1 t) => Pretty2 (Scope t h) where
  prettys2Prec :: Int -> Scope t h t a -> ShowS
prettys2Prec Int
p (Scope h (BV t (h t)) a
x) = Int -> h (BV t (h t)) a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
p h (BV t (h t)) a
x

instance (Pretty2 h, Pretty1 t) => Pretty2 (Scoped h t) where
  prettys2Prec :: Int -> Scoped h t t a -> ShowS
prettys2Prec Int
p (Scoped Scope t h t a
x) = Int -> Scope t h t a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
p Scope t h t a
x


instance (Pretty3 h) => Pretty2 (SFree h) where
  prettys2Prec :: Int -> SFree h t a -> ShowS
prettys2Prec Int
p = \case
    SPure t a
x -> Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
p t a
x
    SWrap h (Scoped (SFree h) t) (SFree h t) a
x -> Int -> h (Scoped (SFree h) t) (SFree h t) a -> ShowS
forall k k k k (h :: ((k -> *) -> k -> *) -> (k -> *) -> k -> *)
       (s :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty3 h, Pretty2 s, Pretty1 t) =>
Int -> h s t a -> ShowS
prettys3Prec Int
p h (Scoped (SFree h) t) (SFree h t) a
x


instance (Pretty2 (OpChoice ops)) => Pretty2 (HFree' ops) where
  prettys2Prec :: Int -> HFree' ops t a -> ShowS
prettys2Prec Int
p = Int -> HFree (OpChoice ops) t a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
p (HFree (OpChoice ops) t a -> ShowS)
-> (HFree' ops t a -> HFree (OpChoice ops) t a)
-> HFree' ops t a
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HFree' ops t a -> HFree (OpChoice ops) t a
forall (ops :: [(* -> *) -> * -> *]) (v :: * -> *) a.
HFree' ops v a -> HFree (OpChoice ops) v a
getHFree'

instance (Pretty2 (OpChoice '[])) where
  pretty2 :: OpChoice '[] t a -> String
pretty2 = OpChoice '[] t a -> String
forall (t :: * -> *) a x. OpChoice '[] t a -> x
noOps


instance (Pretty2 op, Pretty2 (OpChoice ops)) =>
         Pretty2 (OpChoice (op : ops)) where
  prettys2Prec :: Int -> OpChoice (op : ops) t a -> ShowS
prettys2Prec Int
p = \case
    OpThis op t a
x -> Int -> op t a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
p op t a
x
    OpThat OpChoice ops t a
x -> Int -> OpChoice ops t a -> ShowS
forall k k (op :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
p OpChoice ops t a
x

instance {-# OVERLAPPING #-} Pretty String where
  pretty :: ShowS
pretty = ShowS
forall a. a -> a
id

instance {-# OVERLAPPING #-} Pretty a => Pretty [a] where
  prettysPrec :: Int -> [a] -> ShowS
prettysPrec Int
_ [a]
xs = (Endo String -> ShowS
forall a. Endo a -> a -> a
appEndo (Endo String -> ShowS)
-> ([ShowS] -> Endo String) -> [ShowS] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Endo String] -> Endo String
forall a. Monoid a => [a] -> a
mconcat ([Endo String] -> Endo String)
-> ([ShowS] -> [Endo String]) -> [ShowS] -> Endo String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> Endo String) -> [ShowS] -> [Endo String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS -> Endo String
forall a. (a -> a) -> Endo a
Endo) (
    String -> ShowS
showString String
"[ " ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (String -> ShowS
showString String
"\n, ") ([ShowS] -> [ShowS]) -> ([a] -> [ShowS]) -> [a] -> [ShowS]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ShowS) -> [a] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map a -> ShowS
forall a. Pretty a => a -> ShowS
prettys) [a]
xs) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> ShowS
showString String
"\n]"

instance {-# OVERLAPPING #-} Pretty a => Pretty (Maybe a) where
  prettysPrec :: Int -> Maybe a -> ShowS
prettysPrec Int
p (Just a
x) = Int -> a -> ShowS
forall a. Pretty a => Int -> a -> ShowS
prettysPrec Int
p a
x
  prettysPrec Int
_ Maybe a
Nothing  = \String
r -> String
"<nothing>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
r

instance Pretty () where
  pretty :: () -> String
pretty = () -> String
forall a. Show a => a -> String
show