-- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Ord a => a -> a -> Bool
<= Double
n Bool -> Bool -> Bool
&& Double
n forall a. Ord a => a -> a -> Bool
<= Double
1 = (if Double
n forall a. Ord a => a -> a -> Bool
< Double
0 then Text
"-" else Text
"") forall a. Semigroup a => a -> a -> a
<> Text
hex_prefix
        forall a. Semigroup a => a -> a -> a
<> if Text -> Int
Text.length Text
h forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"0" forall a. Semigroup a => a -> a -> a
<> Text
h else Text
h
    | Bool
otherwise = forall a. ShowVal a => a -> Text
show_val Double
n
    where h :: Text
h = String -> Text
txt forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
Numeric.showHex (forall a b. (RealFrac a, Integral b) => a -> b
round (forall a. Num a => a -> a
abs Double
n 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Text
show_val [a]
xs) forall a. Semigroup a => a -> a -> a
<> Text
")"
instance ShowVal a => ShowVal (Set a) where
    show_val :: Set a -> Text
show_val = forall a. ShowVal a => a -> Text
show_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList

instance ShowVal Int where
    show_val :: Int -> Text
show_val = forall a. Show a => a -> Text
showt

instance ShowVal Double where
    show_val :: Double -> Text
show_val = 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 =
        forall a. ShowVal a => a -> Text
show_val (forall a. Ratio a -> a
Ratio.numerator Ratio Int
r) forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
show_val (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) = 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. ShowVal a => a -> Text
show_val 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
"'" forall a. Semigroup a => a -> a -> a
<> (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
quote Text
s 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 forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z' Bool -> Bool -> Bool
|| Char
c forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z' Bool -> Bool -> Bool
|| Char
c 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 forall a. Eq a => a -> a -> Bool
/= Char
' ' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\t' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'='