Value.hs

{-# 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 (Eq, Read, Show, Ord, Generic)

instance Hashable Value
instance MessagePack Value where
    toObject ValueVoid = ObjectNil
    toObject (ValueInt x) = ObjectInt x
    toObject (ValueDouble x) = ObjectDouble x
    toObject (ValueString x) = ObjectStr $ Txt.pack x
    toObject (ValueBool x) = ObjectBool x
    toObject (ValueMatrix (V2 (V2 xx yx) (V2 xy yy))) = toObject [xx, xy, yx, yy]
    toObject (ValueCharSet x) | S.null x = ObjectExt 0x63 "" -- Resolve ambiguity!
        | otherwise = toObject $ CharSet' x
    toObject (ValueLangSet x) = toObject $ LangSet' x
    toObject (ValueRange x) = toObject x

    fromObject ObjectNil = Just ValueVoid
    fromObject (ObjectBool x) = Just $ ValueBool x
    fromObject (ObjectInt x) = Just $ ValueInt x
    fromObject (ObjectFloat x) = Just $ ValueDouble $ realToFrac x
    fromObject (ObjectDouble x) = Just $ ValueDouble x
    fromObject (ObjectStr x) = Just $ ValueString $ Txt.unpack x
    fromObject (ObjectBin _) = Nothing -- Would use for to transfer font faces via underlying bytes.
    fromObject msg
        -- LangSet takes precedance for encoding empty arrays!
        | Just langset <- fromObject msg = Just $ ValueLangSet $ unLangSet langset
        | Just charset <- fromObject msg = Just $ ValueCharSet $ unCharSet charset
        | Just range <- fromObject msg = Just $ ValueRange range
        | Just [xx, xy, yx, yy] <- fromObject msg :: Maybe [Double] =
            -- [Double] decoding is overly generous, potentially conflicts with above.
            Just $ ValueMatrix $ V2 (V2 xx yx) (V2 xy yy)
        | otherwise = Nothing
instance Arbitrary Value where
    arbitrary = oneof [
        --return ValueVoid,
        ValueInt <$> arbitrary,
        ValueDouble <$> arbitrary,
        ValueString <$> Prelude.filter (/= '\0') <$> arbitrary,
        ValueBool <$> arbitrary,
        do
            (a, b, c, d) <- arbitrary
            return $ ValueMatrix $ V2 (V2 a b) (V2 c d),
        ValueCharSet <$> unCharSet <$> arbitrary,
        ValueLangSet <$> unLangSet <$> arbitrary,
        ValueRange <$> arbitrary
      ]

-- | Can the value be processed by FontConfig?
validValue :: Value -> Bool
validValue (ValueString "") = False
validValue (ValueString x) = '\0' `notElem` x
validValue (ValueCharSet x) = validCharSet' $ CharSet' x
validValue (ValueLangSet x) = validLangSet x
validValue (ValueRange x) = validRange x
validValue _ = 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' self | Just ret <- fromValue self = ret
    fromValue' _ = error "Type mismatch!" -- TODO: Throw something nicer!

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