{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
#ifndef NO_GENERICS
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
#endif
module Text.Show.PrettyVal ( PrettyVal(prettyVal) ) where

import Text.Show.Value
import Data.Text(Text)
import qualified Data.Text as Text
import Data.Fixed (Fixed, HasResolution)

#ifndef NO_GENERICS
import Data.Ratio
import Data.Word
import Data.Int
import GHC.Generics
#endif

-- | A class for types that may be reified into a value.
-- Instances of this class may be derived automatically,
-- for datatypes that support `Generics`.
class PrettyVal a where
  prettyVal :: a -> Value
  listValue :: [a] -> Value

#ifndef NO_GENERICS

  default prettyVal :: (GDump (Rep a), Generic a) => a -> Value
  prettyVal = [(Name, Value)] -> Value
oneVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

  default listValue :: [a] -> Value
  listValue = [Value] -> Value
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. PrettyVal a => a -> Value
prettyVal


class GDump f where
  gdump :: f a -> [(Name,Value)]

instance GDump U1 where
  gdump :: forall a. U1 a -> [(Name, Value)]
gdump U1 a
U1 = []

instance (GDump f, GDump g) => GDump (f :*: g) where
  gdump :: forall a. (:*:) f g a -> [(Name, Value)]
gdump (f a
xs :*: g a
ys) = forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
xs forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump g a
ys

instance (GDump f, GDump g) => GDump (f :+: g) where
  gdump :: forall a. (:+:) f g a -> [(Name, Value)]
gdump (L1 f a
x) = forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x
  gdump (R1 g a
x) = forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump g a
x

instance PrettyVal a => GDump (K1 t a) where
  gdump :: forall a. K1 t a a -> [(Name, Value)]
gdump (K1 a
x) = [ (Name
"", forall a. PrettyVal a => a -> Value
prettyVal a
x) ]

instance (GDump f, Datatype d) => GDump (M1 D d f) where
  gdump :: forall a. M1 D d f a -> [(Name, Value)]
gdump (M1 f a
x) = forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x

instance (GDump f, Constructor c) => GDump (M1 C c f) where
  gdump :: forall a. M1 C c f a -> [(Name, Value)]
gdump c :: M1 C c f a
c@(M1 f a
x)
    | forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord M1 C c f a
c = [ (Name
"", Name -> [(Name, Value)] -> Value
Rec   Name
name (forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x)) ]
    | Name -> Bool
isTuple Name
name  = [ (Name
"", [Value] -> Value
Tuple (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x))) ]
    | Bool
otherwise     = [ (Name
"", Name -> [Value] -> Value
Con   Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x))) ]

    where
    name :: Name
name = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Name
conName M1 C c f a
c

    isTuple :: Name -> Bool
isTuple (Char
'(' : Name
cs) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
== Char
',') Name
cs of
                           (Name
_,Name
")") -> Bool
True
                           (Name, Name)
_ -> Bool
False
    isTuple Name
_          = Bool
False

instance (GDump f, Selector s) => GDump (M1 S s f) where
  gdump :: forall a. M1 S s f a -> [(Name, Value)]
gdump it :: M1 S s f a
it@(M1 f a
x) = forall a. a -> [a]
repeat (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> Name
selName M1 S s f a
it) forall a b. [a] -> [b] -> [(a, b)]
`zip` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x)
#endif

oneVal :: [(Name,Value)] -> Value
oneVal :: [(Name, Value)] -> Value
oneVal [(Name, Value)]
x =
  case [(Name, Value)]
x of
    [ (Name
"",Value
v) ]               -> Value
v
    [(Name, Value)]
fs | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Name, Value)]
fs -> Name -> [Value] -> Value
Con Name
"?" (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Value)]
fs)
       | Bool
otherwise           -> Name -> [(Name, Value)] -> Value
Rec Name
"?" [(Name, Value)]
fs


mkNum :: (Ord a, Num a, Show a) => (String -> Value) -> a -> Value
mkNum :: forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
c a
x
  | a
x forall a. Ord a => a -> a -> Bool
>= a
0    = Name -> Value
c (forall a. Show a => a -> Name
show a
x)
  | Bool
otherwise = Value -> Value
Neg (Name -> Value
c (forall a. Show a => a -> Name
show (forall a. Num a => a -> a
negate a
x)))

instance PrettyVal Int     where prettyVal :: Int -> Value
prettyVal   = forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Integer where prettyVal :: Integer -> Value
prettyVal   = forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Float   where prettyVal :: Float -> Value
prettyVal Float
x = Name -> Value
Float (forall a. Show a => a -> Name
show Float
x)
instance PrettyVal Double  where prettyVal :: Double -> Value
prettyVal Double
x = Name -> Value
Float (forall a. Show a => a -> Name
show Double
x)

instance PrettyVal Word8   where prettyVal :: Word8 -> Value
prettyVal Word8
x = Name -> Value
Integer (forall a. Show a => a -> Name
show Word8
x)
instance PrettyVal Word16  where prettyVal :: Word16 -> Value
prettyVal Word16
x = Name -> Value
Integer (forall a. Show a => a -> Name
show Word16
x)
instance PrettyVal Word32  where prettyVal :: Word32 -> Value
prettyVal Word32
x = Name -> Value
Integer (forall a. Show a => a -> Name
show Word32
x)
instance PrettyVal Word64  where prettyVal :: Word64 -> Value
prettyVal Word64
x = Name -> Value
Integer (forall a. Show a => a -> Name
show Word64
x)

instance PrettyVal Int8    where prettyVal :: Int8 -> Value
prettyVal   = forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Int16   where prettyVal :: Int16 -> Value
prettyVal   = forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Int32   where prettyVal :: Int32 -> Value
prettyVal   = forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Int64   where prettyVal :: Int64 -> Value
prettyVal   = forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer

instance PrettyVal Char    where
  prettyVal :: Char -> Value
prettyVal Char
x    = Name -> Value
Char (forall a. Show a => a -> Name
show Char
x)
  listValue :: Name -> Value
listValue Name
xs = Name -> Value
String Name
xs

instance PrettyVal a => PrettyVal [a] where
  prettyVal :: [a] -> Value
prettyVal [a]
xs   = forall a. PrettyVal a => [a] -> Value
listValue [a]
xs

instance (PrettyVal a, Integral a) => PrettyVal (Ratio a) where
  prettyVal :: Ratio a -> Value
prettyVal Ratio a
r = Value -> Value -> Value
Ratio (forall a. PrettyVal a => a -> Value
prettyVal (forall a. Ratio a -> a
numerator Ratio a
r)) (forall a. PrettyVal a => a -> Value
prettyVal (forall a. Ratio a -> a
denominator Ratio a
r))

instance HasResolution p => PrettyVal (Fixed p) where prettyVal :: Fixed p -> Value
prettyVal Fixed p
x = Name -> Value
Float (forall a. Show a => a -> Name
show Fixed p
x)

instance (PrettyVal a1, PrettyVal a2) => PrettyVal (a1,a2)
instance (PrettyVal a1, PrettyVal a2, PrettyVal a3) => PrettyVal (a1,a2,a3)
instance (PrettyVal a1, PrettyVal a2, PrettyVal a3, PrettyVal a4) =>
  PrettyVal (a1,a2,a3,a4)

instance (PrettyVal a1, PrettyVal a2, PrettyVal a3,
          PrettyVal a4, PrettyVal a5) => PrettyVal (a1,a2,a3,a4,a5)

instance (PrettyVal a1, PrettyVal a2, PrettyVal a3,
          PrettyVal a4, PrettyVal a5, PrettyVal a6) =>
  PrettyVal (a1,a2,a3,a4,a5,a6)

instance (PrettyVal a1, PrettyVal a2, PrettyVal a3,
          PrettyVal a4, PrettyVal a5, PrettyVal a6, PrettyVal a7) =>
  PrettyVal (a1,a2,a3,a4,a5,a6,a7)

instance PrettyVal Bool
instance PrettyVal Ordering
instance PrettyVal a => PrettyVal (Maybe a)
instance (PrettyVal a, PrettyVal b) => PrettyVal (Either a b)

instance PrettyVal Text where
  prettyVal :: Text -> Value
prettyVal = Name -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name
Text.unpack