pretty-show-1.6.16/Text/Show/PrettyVal.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE Safe #-}
   3 #ifndef NO_GENERICS
   4 {-# LANGUAGE TypeOperators #-}
   5 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
   6 {-# LANGUAGE DefaultSignatures #-}
   7 #endif
   8 module Text.Show.PrettyVal ( PrettyVal(prettyVal) ) where
   9
  10 import Text.Show.Value
  11
  12 #ifndef NO_GENERICS
  13 import Data.Ratio
  14 import Data.Word
  15 import Data.Int
  16 import GHC.Generics
  17 #endif
  18
  19 -- | A class for types that may be reified into a value.
  20 -- Instances of this class may be derived automatically,
  21 -- for datatypes that support `Generics`.
  22 class PrettyVal a where
  23   prettyVal :: a -> Value
  24   listValue :: [a] -> Value
  25
  26 #ifndef NO_GENERICS
  27
  28   default prettyVal :: (GDump (Rep a), Generic a) => a -> Value
  29   prettyVal = oneVal . gdump . from
  30
  31   default listValue :: [a] -> Value
  32   listValue = List . map prettyVal
  33
  34
  35 class GDump f where
  36   gdump :: f a -> [(Name,Value)]
  37
  38 instance GDump U1 where
  39   gdump U1 = []
  40
  41 instance (GDump f, GDump g) => GDump (f :*: g) where
  42   gdump (xs :*: ys) = gdump xs ++ gdump ys
  43
  44 instance (GDump f, GDump g) => GDump (f :+: g) where
  45   gdump (L1 x) = gdump x
  46   gdump (R1 x) = gdump x
  47
  48 instance PrettyVal a => GDump (K1 t a) where
  49   gdump (K1 x) = [ ("", prettyVal x) ]
  50
  51 instance (GDump f, Datatype d) => GDump (M1 D d f) where
  52   gdump (M1 x) = gdump x
  53
  54 instance (GDump f, Constructor c) => GDump (M1 C c f) where
  55   gdump c@(M1 x)
  56     | conIsRecord c = [ ("", Rec   name (gdump x)) ]
  57     | isTuple name  = [ ("", Tuple (map snd (gdump x))) ]
  58     | otherwise     = [ ("", Con   name (map snd (gdump x))) ]
  59
  60     where
  61     name = conName c
  62
  63     isTuple ('(' : cs) = case span (== ',') cs of
  64                            (_,")") -> True
  65                            _ -> False
  66     isTuple _          = False
  67
  68 instance (GDump f, Selector s) => GDump (M1 S s f) where
  69   gdump it@(M1 x) = repeat (selName it) `zip` map snd (gdump x)
  70
  71 oneVal :: [(Name,Value)] -> Value
  72 oneVal x =
  73   case x of
  74     [ ("",v) ]               -> v
  75     fs | all (null . fst) fs -> Con "?" (map snd fs)
  76        | otherwise           -> Rec "?" fs
  77
  78
  79 mkNum :: (Ord a, Num a, Show a) => (String -> Value) -> a -> Value
  80 mkNum c x
  81   | x >= 0    = c (show x)
  82   | otherwise = Neg (c (show (negate x)))
  83
  84 instance PrettyVal Int     where prettyVal   = mkNum Integer
  85 instance PrettyVal Integer where prettyVal   = mkNum Integer
  86 instance PrettyVal Float   where prettyVal x = Float (show x)
  87 instance PrettyVal Double  where prettyVal x = Float (show x)
  88
  89 instance PrettyVal Word8   where prettyVal x = Integer (show x)
  90 instance PrettyVal Word16  where prettyVal x = Integer (show x)
  91 instance PrettyVal Word32  where prettyVal x = Integer (show x)
  92 instance PrettyVal Word64  where prettyVal x = Integer (show x)
  93
  94 instance PrettyVal Int8    where prettyVal   = mkNum Integer
  95 instance PrettyVal Int16   where prettyVal   = mkNum Integer
  96 instance PrettyVal Int32   where prettyVal   = mkNum Integer
  97 instance PrettyVal Int64   where prettyVal   = mkNum Integer
  98
  99 instance PrettyVal Char    where
 100   prettyVal x    = Char (show x)
 101   listValue xs = String xs
 102
 103 instance PrettyVal a => PrettyVal [a] where
 104   prettyVal xs   = listValue xs
 105
 106 instance (PrettyVal a, Integral a) => PrettyVal (Ratio a) where
 107   prettyVal r = Ratio (prettyVal (numerator r)) (prettyVal (denominator r))
 108
 109 instance (PrettyVal a1, PrettyVal a2) => PrettyVal (a1,a2)
 110 instance (PrettyVal a1, PrettyVal a2, PrettyVal a3) => PrettyVal (a1,a2,a3)
 111 instance (PrettyVal a1, PrettyVal a2, PrettyVal a3,
 112           PrettyVal a4) => PrettyVal (a1,a2,a3,a4)
 113
 114 instance (PrettyVal a1, PrettyVal a2, PrettyVal a3,
 115           PrettyVal a4, PrettyVal a5) => PrettyVal (a1,a2,a3,a4,a5)
 116
 117 instance (PrettyVal a1, PrettyVal a2, PrettyVal a3,
 118           PrettyVal a4, PrettyVal a5, PrettyVal a6) => PrettyVal (a1,a2,a3,a4,a5,a6)
 119
 120 instance (PrettyVal a1, PrettyVal a2, PrettyVal a3,
 121           PrettyVal a4, PrettyVal a5, PrettyVal a6, PrettyVal a7)
 122   => PrettyVal (a1,a2,a3,a4,a5,a6,a7)
 123
 124 instance PrettyVal Bool
 125 instance PrettyVal Ordering
 126 instance PrettyVal a => PrettyVal (Maybe a)
 127 instance (PrettyVal a, PrettyVal b) => PrettyVal (Either a b)
 128
 129 #endif
 130