{-# 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 = oneVal . gdump . from

  default listValue :: [a] -> Value
  listValue = List . map prettyVal


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

instance GDump U1 where
  gdump U1 = []

instance (GDump f, GDump g) => GDump (f :*: g) where
  gdump (xs :*: ys) = gdump xs ++ gdump ys

instance (GDump f, GDump g) => GDump (f :+: g) where
  gdump (L1 x) = gdump x
  gdump (R1 x) = gdump x

instance PrettyVal a => GDump (K1 t a) where
  gdump (K1 x) = [ ("", prettyVal x) ]

instance (GDump f, Datatype d) => GDump (M1 D d f) where
  gdump (M1 x) = gdump x

instance (GDump f, Constructor c) => GDump (M1 C c f) where
  gdump c@(M1 x)
    | conIsRecord c = [ ("", Rec   name (gdump x)) ]
    | isTuple name  = [ ("", Tuple (map snd (gdump x))) ]
    | otherwise     = [ ("", Con   name (map snd (gdump x))) ]

    where
    name = conName c

    isTuple ('(' : cs) = case span (== ',') cs of
                           (_,")") -> True
                           _ -> False
    isTuple _          = False

instance (GDump f, Selector s) => GDump (M1 S s f) where
  gdump it@(M1 x) = repeat (selName it) `zip` map snd (gdump x)
#endif

oneVal :: [(Name,Value)] -> Value
oneVal x =
  case x of
    [ ("",v) ]               -> v
    fs | all (null . fst) fs -> Con "?" (map snd fs)
       | otherwise           -> Rec "?" fs


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

instance PrettyVal Int     where prettyVal   = mkNum Integer
instance PrettyVal Integer where prettyVal   = mkNum Integer
instance PrettyVal Float   where prettyVal x = Float (show x)
instance PrettyVal Double  where prettyVal x = Float (show x)

instance PrettyVal Word8   where prettyVal x = Integer (show x)
instance PrettyVal Word16  where prettyVal x = Integer (show x)
instance PrettyVal Word32  where prettyVal x = Integer (show x)
instance PrettyVal Word64  where prettyVal x = Integer (show x)

instance PrettyVal Int8    where prettyVal   = mkNum Integer
instance PrettyVal Int16   where prettyVal   = mkNum Integer
instance PrettyVal Int32   where prettyVal   = mkNum Integer
instance PrettyVal Int64   where prettyVal   = mkNum Integer

instance PrettyVal Char    where
  prettyVal x    = Char (show x)
  listValue xs = String xs

instance PrettyVal a => PrettyVal [a] where
  prettyVal xs   = listValue xs

instance (PrettyVal a, Integral a) => PrettyVal (Ratio a) where
  prettyVal r = Ratio (prettyVal (numerator r)) (prettyVal (denominator r))

instance HasResolution p => PrettyVal (Fixed p) where prettyVal x = Float (show 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 = String . Text.unpack