{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-- | A dynamic type system for patterns.
module Graphics.Text.Font.Choose.Value(Value(..), validValue, ToValue(..)) where

import Linear.Matrix (M22)
import Linear.V2 (V2(..))
import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet'(..), validCharSet')
import qualified Data.IntSet as S
--import FreeType.Core.Base (FT_Face(..))
import Graphics.Text.Font.Choose.LangSet (LangSet, LangSet'(..), validLangSet)
import Graphics.Text.Font.Choose.Range (Range, validRange)

import Data.MessagePack (MessagePack(..), Object(..))
import Test.QuickCheck (Arbitrary(..), oneof)
import GHC.Generics (Generic)
import Data.Hashable (Hashable(..))
import qualified Data.Text as Txt

-- | A dynamic type system for `Pattern`s.
data Value = ValueVoid
    | ValueInt Int
    | ValueDouble Double
    | ValueString String
    | ValueBool Bool
    | ValueMatrix (M22 Double)
    | ValueCharSet CharSet
--    | ValueFTFace FT_Face -- FIXME: Is it worth going through the trouble to bridge this?
    | ValueLangSet LangSet
    | ValueRange Range deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, ReadPrec [Value]
ReadPrec Value
Int -> ReadS Value
ReadS [Value]
(Int -> ReadS Value)
-> ReadS [Value]
-> ReadPrec Value
-> ReadPrec [Value]
-> Read Value
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Value
readsPrec :: Int -> ReadS Value
$creadList :: ReadS [Value]
readList :: ReadS [Value]
$creadPrec :: ReadPrec Value
readPrec :: ReadPrec Value
$creadListPrec :: ReadPrec [Value]
readListPrec :: ReadPrec [Value]
Read, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, Eq Value
Eq Value
-> (Value -> Value -> Ordering)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Value)
-> (Value -> Value -> Value)
-> Ord Value
Value -> Value -> Bool
Value -> Value -> Ordering
Value -> Value -> Value
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Value -> Value -> Ordering
compare :: Value -> Value -> Ordering
$c< :: Value -> Value -> Bool
< :: Value -> Value -> Bool
$c<= :: Value -> Value -> Bool
<= :: Value -> Value -> Bool
$c> :: Value -> Value -> Bool
> :: Value -> Value -> Bool
$c>= :: Value -> Value -> Bool
>= :: Value -> Value -> Bool
$cmax :: Value -> Value -> Value
max :: Value -> Value -> Value
$cmin :: Value -> Value -> Value
min :: Value -> Value -> Value
Ord, (forall x. Value -> Rep Value x)
-> (forall x. Rep Value x -> Value) -> Generic Value
forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Value -> Rep Value x
from :: forall x. Value -> Rep Value x
$cto :: forall x. Rep Value x -> Value
to :: forall x. Rep Value x -> Value
Generic)

instance Hashable Value
instance MessagePack Value where
    toObject :: Value -> Object
toObject Value
ValueVoid = Object
ObjectNil
    toObject (ValueInt Int
x) = Int -> Object
ObjectInt Int
x
    toObject (ValueDouble Double
x) = Double -> Object
ObjectDouble Double
x
    toObject (ValueString String
x) = Text -> Object
ObjectStr (Text -> Object) -> Text -> Object
forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
x
    toObject (ValueBool Bool
x) = Bool -> Object
ObjectBool Bool
x
    toObject (ValueMatrix (V2 (V2 Double
xx Double
yx) (V2 Double
xy Double
yy))) = [Double] -> Object
forall a. MessagePack a => a -> Object
toObject [Double
xx, Double
xy, Double
yx, Double
yy]
    toObject (ValueCharSet CharSet
x) | CharSet -> Bool
S.null CharSet
x = Word8 -> ByteString -> Object
ObjectExt Word8
0x63 ByteString
"" -- Resolve ambiguity!
        | Bool
otherwise = CharSet' -> Object
forall a. MessagePack a => a -> Object
toObject (CharSet' -> Object) -> CharSet' -> Object
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet'
CharSet' CharSet
x
    toObject (ValueLangSet LangSet
x) = LangSet' -> Object
forall a. MessagePack a => a -> Object
toObject (LangSet' -> Object) -> LangSet' -> Object
forall a b. (a -> b) -> a -> b
$ LangSet -> LangSet'
LangSet' LangSet
x
    toObject (ValueRange Range
x) = Range -> Object
forall a. MessagePack a => a -> Object
toObject Range
x

    fromObject :: Object -> Maybe Value
fromObject Object
ObjectNil = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
ValueVoid
    fromObject (ObjectBool Bool
x) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
ValueBool Bool
x
    fromObject (ObjectInt Int
x) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
ValueInt Int
x
    fromObject (ObjectFloat Float
x) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
ValueDouble (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
x
    fromObject (ObjectDouble Double
x) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
ValueDouble Double
x
    fromObject (ObjectStr Text
x) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ String -> Value
ValueString (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
x
    fromObject (ObjectBin ByteString
_) = Maybe Value
forall a. Maybe a
Nothing -- Would use for to transfer font faces via underlying bytes.
    fromObject Object
msg
        -- LangSet takes precedance for encoding empty arrays!
        | Just LangSet'
langset <- Object -> Maybe LangSet'
forall a. MessagePack a => Object -> Maybe a
fromObject Object
msg = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ LangSet -> Value
ValueLangSet (LangSet -> Value) -> LangSet -> Value
forall a b. (a -> b) -> a -> b
$ LangSet' -> LangSet
unLangSet LangSet'
langset
        | Just CharSet'
charset <- Object -> Maybe CharSet'
forall a. MessagePack a => Object -> Maybe a
fromObject Object
msg = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ CharSet -> Value
ValueCharSet (CharSet -> Value) -> CharSet -> Value
forall a b. (a -> b) -> a -> b
$ CharSet' -> CharSet
unCharSet CharSet'
charset
        | Just Range
range <- Object -> Maybe Range
forall a. MessagePack a => Object -> Maybe a
fromObject Object
msg = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Range -> Value
ValueRange Range
range
        | Just [Double
xx, Double
xy, Double
yx, Double
yy] <- Object -> Maybe [Double]
forall a. MessagePack a => Object -> Maybe a
fromObject Object
msg :: Maybe [Double] =
            -- [Double] decoding is overly generous, potentially conflicts with above.
            Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ M22 Double -> Value
ValueMatrix (M22 Double -> Value) -> M22 Double -> Value
forall a b. (a -> b) -> a -> b
$ V2 Double -> V2 Double -> M22 Double
forall a. a -> a -> V2 a
V2 (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
xx Double
yx) (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
xy Double
yy)
        | Bool
otherwise = Maybe Value
forall a. Maybe a
Nothing
instance Arbitrary Value where
    arbitrary :: Gen Value
arbitrary = [Gen Value] -> Gen Value
forall a. HasCallStack => [Gen a] -> Gen a
oneof [
        --return ValueVoid,
        Int -> Value
ValueInt (Int -> Value) -> Gen Int -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary,
        Double -> Value
ValueDouble (Double -> Value) -> Gen Double -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Double
forall a. Arbitrary a => Gen a
arbitrary,
        String -> Value
ValueString (String -> Value) -> ShowS -> String -> Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0') (String -> Value) -> Gen String -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
forall a. Arbitrary a => Gen a
arbitrary,
        Bool -> Value
ValueBool (Bool -> Value) -> Gen Bool -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary,
        do
            (Double
a, Double
b, Double
c, Double
d) <- Gen (Double, Double, Double, Double)
forall a. Arbitrary a => Gen a
arbitrary
            Value -> Gen Value
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Gen Value) -> Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ M22 Double -> Value
ValueMatrix (M22 Double -> Value) -> M22 Double -> Value
forall a b. (a -> b) -> a -> b
$ V2 Double -> V2 Double -> M22 Double
forall a. a -> a -> V2 a
V2 (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
a Double
b) (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
c Double
d),
        CharSet -> Value
ValueCharSet (CharSet -> Value) -> (CharSet' -> CharSet) -> CharSet' -> Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharSet' -> CharSet
unCharSet (CharSet' -> Value) -> Gen CharSet' -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen CharSet'
forall a. Arbitrary a => Gen a
arbitrary,
        LangSet -> Value
ValueLangSet (LangSet -> Value) -> (LangSet' -> LangSet) -> LangSet' -> Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LangSet' -> LangSet
unLangSet (LangSet' -> Value) -> Gen LangSet' -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LangSet'
forall a. Arbitrary a => Gen a
arbitrary,
        Range -> Value
ValueRange (Range -> Value) -> Gen Range -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Range
forall a. Arbitrary a => Gen a
arbitrary
      ]

-- | Can the value be processed by FontConfig?
validValue :: Value -> Bool
validValue :: Value -> Bool
validValue (ValueString String
"") = Bool
False
validValue (ValueString String
x) = Char
'\0' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
x
validValue (ValueCharSet CharSet
x) = CharSet' -> Bool
validCharSet' (CharSet' -> Bool) -> CharSet' -> Bool
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet'
CharSet' CharSet
x
validValue (ValueLangSet LangSet
x) = LangSet -> Bool
validLangSet LangSet
x
validValue (ValueRange Range
x) = Range -> Bool
validRange Range
x
validValue Value
_ = Bool
True

-- | Coerces compiletime types to or from runtime types.
class ToValue x where
    toValue :: x -> Value
    fromValue :: Value -> Maybe x
    fromValue' :: Value -> x -- throws Result.Error
    fromValue' Value
self | Just x
ret <- Value -> Maybe x
forall x. ToValue x => Value -> Maybe x
fromValue Value
self = x
ret
    fromValue' Value
_ = String -> x
forall a. HasCallStack => String -> a
error String
"Type mismatch!" -- TODO: Throw something nicer!

instance ToValue () where
    toValue :: () -> Value
toValue () = Value
ValueVoid
    fromValue :: Value -> Maybe ()
fromValue Value
ValueVoid = () -> Maybe ()
forall a. a -> Maybe a
Just ()
    fromValue Value
_ = Maybe ()
forall a. Maybe a
Nothing
instance ToValue Int where
    toValue :: Int -> Value
toValue = Int -> Value
ValueInt
    fromValue :: Value -> Maybe Int
fromValue (ValueInt Int
x) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
    fromValue Value
_ = Maybe Int
forall a. Maybe a
Nothing
instance ToValue Double where
    toValue :: Double -> Value
toValue = Double -> Value
ValueDouble
    fromValue :: Value -> Maybe Double
fromValue (ValueDouble Double
x) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x
    fromValue Value
_ = Maybe Double
forall a. Maybe a
Nothing
instance ToValue String where
    toValue :: String -> Value
toValue = String -> Value
ValueString
    fromValue :: Value -> Maybe String
fromValue (ValueString String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
    fromValue Value
_ = Maybe String
forall a. Maybe a
Nothing
instance ToValue Bool where
    toValue :: Bool -> Value
toValue = Bool -> Value
ValueBool
    fromValue :: Value -> Maybe Bool
fromValue (ValueBool Bool
x) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x
    fromValue Value
_ = Maybe Bool
forall a. Maybe a
Nothing
instance ToValue (M22 Double) where
    toValue :: M22 Double -> Value
toValue = M22 Double -> Value
ValueMatrix
    fromValue :: Value -> Maybe (M22 Double)
fromValue (ValueMatrix M22 Double
x) = M22 Double -> Maybe (M22 Double)
forall a. a -> Maybe a
Just M22 Double
x
    fromValue Value
_ = Maybe (M22 Double)
forall a. Maybe a
Nothing
instance ToValue CharSet' where
    toValue :: CharSet' -> Value
toValue = CharSet -> Value
ValueCharSet (CharSet -> Value) -> (CharSet' -> CharSet) -> CharSet' -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharSet' -> CharSet
unCharSet
    fromValue :: Value -> Maybe CharSet'
fromValue (ValueCharSet CharSet
x) = CharSet' -> Maybe CharSet'
forall a. a -> Maybe a
Just (CharSet' -> Maybe CharSet') -> CharSet' -> Maybe CharSet'
forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet'
CharSet' CharSet
x
    fromValue Value
_ = Maybe CharSet'
forall a. Maybe a
Nothing
--instance ToValue FT_Face where
--    toValue = ValueFTFace
--    fromValue (ValueFTFace x) = Just x
--    fromValue _ = Nothing
instance ToValue LangSet' where
    toValue :: LangSet' -> Value
toValue = LangSet -> Value
ValueLangSet (LangSet -> Value) -> (LangSet' -> LangSet) -> LangSet' -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LangSet' -> LangSet
unLangSet
    fromValue :: Value -> Maybe LangSet'
fromValue (ValueLangSet LangSet
x) = LangSet' -> Maybe LangSet'
forall a. a -> Maybe a
Just (LangSet' -> Maybe LangSet') -> LangSet' -> Maybe LangSet'
forall a b. (a -> b) -> a -> b
$ LangSet -> LangSet'
LangSet' LangSet
x
    fromValue Value
_ = Maybe LangSet'
forall a. Maybe a
Nothing
instance ToValue Range where
    toValue :: Range -> Value
toValue = Range -> Value
ValueRange
    fromValue :: Value -> Maybe Range
fromValue (ValueRange Range
x) = Range -> Maybe Range
forall a. a -> Maybe a
Just Range
x
    fromValue Value
_ = Maybe Range
forall a. Maybe a
Nothing
instance ToValue Value where
    toValue :: Value -> Value
toValue = Value -> Value
forall a. a -> a
id
    fromValue :: Value -> Maybe Value
fromValue = Value -> Maybe Value
forall a. a -> Maybe a
Just