{-# 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 ([(Name, Value)] -> Value) -> (a -> [(Name, Value)]) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> [(Name, Value)]
forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump (Rep a Any -> [(Name, Value)])
-> (a -> Rep a Any) -> a -> [(Name, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

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


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

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

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

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

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

instance (GDump f, Datatype d) => GDump (M1 D d f) where
  gdump :: M1 D d f a -> [(Name, Value)]
gdump (M1 f a
x) = f a -> [(Name, Value)]
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 :: M1 C c f a -> [(Name, Value)]
gdump c :: M1 C c f a
c@(M1 f a
x)
    | M1 C c f a -> Bool
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 (f a -> [(Name, Value)]
forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x)) ]
    | Name -> Bool
isTuple Name
name  = [ (Name
"", [Value] -> Value
Tuple (((Name, Value) -> Value) -> [(Name, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Value) -> Value
forall a b. (a, b) -> b
snd (f a -> [(Name, Value)]
forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x))) ]
    | Bool
otherwise     = [ (Name
"", Name -> [Value] -> Value
Con   Name
name (((Name, Value) -> Value) -> [(Name, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Value) -> Value
forall a b. (a, b) -> b
snd (f a -> [(Name, Value)]
forall (f :: * -> *) a. GDump f => f a -> [(Name, Value)]
gdump f a
x))) ]

    where
    name :: Name
name = M1 C c f a -> 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 (Char -> Bool) -> Name -> (Name, Name)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
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 :: M1 S s f a -> [(Name, Value)]
gdump it :: M1 S s f a
it@(M1 f a
x) = Name -> [Name]
forall a. a -> [a]
repeat (M1 S s f a -> Name
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) [Name] -> [Value] -> [(Name, Value)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ((Name, Value) -> Value) -> [(Name, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Value) -> Value
forall a b. (a, b) -> b
snd (f a -> [(Name, Value)]
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 | ((Name, Value) -> Bool) -> [(Name, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Name -> Bool) -> ((Name, Value) -> Name) -> (Name, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Value) -> Name
forall a b. (a, b) -> a
fst) [(Name, Value)]
fs -> Name -> [Value] -> Value
Con Name
"?" (((Name, Value) -> Value) -> [(Name, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Value) -> Value
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 :: (Name -> Value) -> a -> Value
mkNum Name -> Value
c a
x
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0    = Name -> Value
c (a -> Name
forall a. Show a => a -> Name
show a
x)
  | Bool
otherwise = Value -> Value
Neg (Name -> Value
c (a -> Name
forall a. Show a => a -> Name
show (a -> a
forall a. Num a => a -> a
negate a
x)))

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

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

instance PrettyVal Int8    where prettyVal :: Int8 -> Value
prettyVal   = (Name -> Value) -> Int8 -> Value
forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Int16   where prettyVal :: Int16 -> Value
prettyVal   = (Name -> Value) -> Int16 -> Value
forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Int32   where prettyVal :: Int32 -> Value
prettyVal   = (Name -> Value) -> Int32 -> Value
forall a. (Ord a, Num a, Show a) => (Name -> Value) -> a -> Value
mkNum Name -> Value
Integer
instance PrettyVal Int64   where prettyVal :: Int64 -> Value
prettyVal   = (Name -> Value) -> Int64 -> Value
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 (Char -> Name
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   = [a] -> Value
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 (a -> Value
forall a. PrettyVal a => a -> Value
prettyVal (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
r)) (a -> Value
forall a. PrettyVal a => a -> Value
prettyVal (Ratio a -> a
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 (Fixed p -> Name
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 (Name -> Value) -> (Text -> Name) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name
Text.unpack