{-# LANGUAGE DefaultSignatures #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Derive.ShowVal where
import qualified Data.Char as Char
import qualified Data.Ratio as Ratio
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Numeric
import qualified Util.Doc as Doc
import qualified Util.Num as Num
import Global hiding (pretty)
class ShowVal a where
show_val :: a -> Text
default show_val :: (Show a, Enum a, Bounded a) => a -> Text
show_val = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
hex_prefix :: Text
hex_prefix :: Text
hex_prefix = Text
"`0x`"
show_hex_val :: Double -> Text
show_hex_val :: Double -> Text
show_hex_val Double
n
| -Double
1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
n Bool -> Bool -> Bool
&& Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1 = (if Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 then Text
"-" else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hex_prefix
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Text -> Int
Text.length Text
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
h else Text
h
| Bool
otherwise = Double -> Text
forall a. ShowVal a => a -> Text
show_val Double
n
where h :: Text
h = String -> Text
txt (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
Numeric.showHex (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Double
forall a. Num a => a -> a
abs Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0xff)) String
""
is_hex_val :: Text -> Bool
is_hex_val :: Text -> Bool
is_hex_val = (Text
hex_prefix `Text.isPrefixOf`)
doc :: ShowVal a => a -> Doc.Doc
doc :: forall a. ShowVal a => a -> Doc
doc = Text -> Doc
Doc.literal (Text -> Doc) -> (a -> Text) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. ShowVal a => a -> Text
show_val
instance ShowVal a => ShowVal [a] where
show_val :: [a] -> Text
show_val [] = Text
"(list)"
show_val [a]
xs = Text
"(list " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords ((a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
forall a. ShowVal a => a -> Text
show_val [a]
xs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
instance ShowVal a => ShowVal (Set a) where
show_val :: Set a -> Text
show_val = [a] -> Text
forall a. ShowVal a => a -> Text
show_val ([a] -> Text) -> (Set a -> [a]) -> Set a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList
instance ShowVal Int where
show_val :: Int -> Text
show_val = Int -> Text
forall a. Show a => a -> Text
showt
instance ShowVal Double where
show_val :: Double -> Text
show_val = Int -> Double -> Text
forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
3
instance ShowVal (Ratio.Ratio Int) where
show_val :: Ratio Int -> Text
show_val Ratio Int
r =
Int -> Text
forall a. ShowVal a => a -> Text
show_val (Ratio Int -> Int
forall a. Ratio a -> a
Ratio.numerator Ratio Int
r) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. ShowVal a => a -> Text
show_val (Ratio Int -> Int
forall a. Ratio a -> a
Ratio.denominator Ratio Int
r)
instance ShowVal a => ShowVal (Maybe a) where
show_val :: Maybe a -> Text
show_val Maybe a
Nothing = Text
"_"
show_val (Just a
a) = a -> Text
forall a. ShowVal a => a -> Text
show_val a
a
instance (ShowVal a, ShowVal b) => ShowVal (Either a b) where
show_val :: Either a b -> Text
show_val = (a -> Text) -> (b -> Text) -> Either a b -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Text
forall a. ShowVal a => a -> Text
show_val b -> Text
forall a. ShowVal a => a -> Text
show_val
instance ShowVal Bool where
show_val :: Bool -> Text
show_val Bool
b = if Bool
b then Text
"t" else Text
"f"
instance ShowVal Text where
show_val :: Text -> Text
show_val Text
s
| Bool
bare = Text
s
| Bool
otherwise = Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
quote Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
where
bare :: Bool
bare = case Text -> Maybe (Char, Text)
Text.uncons Text
s of
Just (Char
c, Text
cs) -> Char -> Bool
is_unquoted_head Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
is_unquoted_body Text
cs
Maybe (Char, Text)
Nothing -> Bool
False
quote :: Char -> Text
quote Char
'\'' = Text
"''"
quote Char
c = Char -> Text
Text.singleton Char
c
is_unquoted_head :: Char -> Bool
is_unquoted_head :: Char -> Bool
is_unquoted_head Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
is_unquoted_body :: Char -> Bool
is_unquoted_body :: Char -> Bool
is_unquoted_body Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'='