-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE DefaultSignatures #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- ShowVal.show_val
-- | The 'show_val' method turns haskell values back to tracklang expressions.
-- It should be the inverse of 'Derive.Typecheck.from_val' .
-- 'Derive.Parse.parse_val'.
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)


-- | Instances of ShowVal can be turned back into tracklang syntax.  Everything
-- produced by show_val should be parseable by "Derive.Parse", except values
-- that have no literal syntax, such as VPitch.
--
-- At least one place that relies on this is 'Derive.Call.Note.inverting'.
class ShowVal a where
    show_val :: a -> Text
    -- This intentionally has redundant constraints, which correspond to
    -- Typecheck.TEnum.  Any old Showable is unlikely to be Typecheckable.
    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`"

-- | VNums have hex and decimal literals, and show_val produces the decimal
-- one.  So I need a way to produce the hex literal.
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`)

-- | Show a val for inclusion into CallDoc.
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

-- Really these instances should go in "Derive.Parse", but it imports
-- "Derive.DeriveT", which needs them.

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
    -- This is a bit sketchy because while _ can mean Nothing, it actually
    -- means use the default, which may not be Nothing.
    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"

-- | This should be the inverse of 'Derive.Parse.p_str' and
-- 'Derive.Parse.p_unquoted_str'.
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
'='