{-# LANGUAGE DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-}
module Graphics.Text.Font.Choose.Value (Value(..), Value_, withValue, thawValue,
    value'Size, ToValue(..)) where

import Linear.Matrix (M22)
import Linear.V2 (V2(..))
import Graphics.Text.Font.Choose.CharSet (CharSet, withCharSet, thawCharSet)
import FreeType.Core.Base (FT_Face(..))
import Graphics.Text.Font.Choose.LangSet (LangSet, withLangSet, thawLangSet)
import Graphics.Text.Font.Choose.Range (Range, withRange, thawRange)
import Control.Exception (throw)

import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Array (advancePtr)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.C.String (withCString, peekCString)

import GHC.Generics (Generic)
import Data.Hashable (Hashable)
import Graphics.Text.Font.Choose.Result (Word8, throwNull, Error(ErrTypeMismatch))

-- | 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
    | ValueLangSet LangSet
    | ValueRange Range deriving (Value -> Value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Eq 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
min :: Value -> Value -> Value
$cmin :: Value -> Value -> Value
max :: Value -> Value -> Value
$cmax :: Value -> Value -> Value
>= :: Value -> Value -> Bool
$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
compare :: Value -> Value -> Ordering
$ccompare :: Value -> Value -> Ordering
Ord, 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
$cto :: forall x. Rep Value x -> Value
$cfrom :: forall x. Value -> Rep Value x
Generic)

instance Hashable Value

-- | Coerces compiletime types to 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 <- forall x. ToValue x => Value -> Maybe x
fromValue Value
self = x
ret
    fromValue' Value
_ = forall a e. Exception e => e -> a
throw Error
ErrTypeMismatch

instance ToValue () where
    toValue :: () -> Value
toValue () = Value
ValueVoid
    fromValue :: Value -> Maybe ()
fromValue Value
ValueVoid = forall a. a -> Maybe a
Just ()
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue Int where
    toValue :: Int -> Value
toValue = Int -> Value
ValueInt
    fromValue :: Value -> Maybe Int
fromValue (ValueInt Int
x) = forall a. a -> Maybe a
Just Int
x
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue Double where
    toValue :: Double -> Value
toValue = Double -> Value
ValueDouble
    fromValue :: Value -> Maybe Double
fromValue (ValueDouble Double
x) = forall a. a -> Maybe a
Just Double
x
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue String where
    toValue :: String -> Value
toValue = String -> Value
ValueString
    fromValue :: Value -> Maybe String
fromValue (ValueString String
x) = forall a. a -> Maybe a
Just String
x
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue Bool where
    toValue :: Bool -> Value
toValue = Bool -> Value
ValueBool
    fromValue :: Value -> Maybe Bool
fromValue (ValueBool Bool
x) = forall a. a -> Maybe a
Just Bool
x
    fromValue Value
_ = 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) = forall a. a -> Maybe a
Just M22 Double
x
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue CharSet where
    toValue :: CharSet -> Value
toValue = CharSet -> Value
ValueCharSet
    fromValue :: Value -> Maybe CharSet
fromValue (ValueCharSet CharSet
x) = forall a. a -> Maybe a
Just CharSet
x
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue FT_Face where
    toValue :: FT_Face -> Value
toValue = FT_Face -> Value
ValueFTFace
    fromValue :: Value -> Maybe FT_Face
fromValue (ValueFTFace FT_Face
x) = forall a. a -> Maybe a
Just FT_Face
x
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue LangSet where
    toValue :: LangSet -> Value
toValue = LangSet -> Value
ValueLangSet
    fromValue :: Value -> Maybe LangSet
fromValue (ValueLangSet LangSet
x) = forall a. a -> Maybe a
Just LangSet
x
    fromValue Value
_ = forall a. Maybe a
Nothing
instance ToValue Range where
    toValue :: Range -> Value
toValue = Range -> Value
ValueRange
    fromValue :: Value -> Maybe Range
fromValue (ValueRange Range
x) = forall a. a -> Maybe a
Just Range
x
    fromValue Value
_ = forall a. Maybe a
Nothing

------
--- Low-level
------

type Value_ = Ptr Int

foreign import ccall "size_value" value'Size :: Int
pokeUnion :: Ptr a -> a -> IO ()
pokeUnion Ptr a
ptr a
x = forall a b. Ptr a -> Ptr b
castPtr (Ptr a
ptr forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int
1) forall a. Storable a => Ptr a -> a -> IO ()
`poke` a
x

withValue :: Value -> (Value_ -> IO a) -> IO a
withValue :: forall a. Value -> (Value_ -> IO a) -> IO a
withValue Value
ValueVoid Value_ -> IO a
cb = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
    forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
0
    Value_ -> IO a
cb Value_
val'
withValue (ValueInt Int
x) Value_ -> IO a
cb = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
    forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
1
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Value_
val' Int
1 Int
x
    Value_ -> IO a
cb Value_
val'
withValue (ValueDouble Double
x) Value_ -> IO a
cb = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
    forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
2
    forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' Double
x
    Value_ -> IO a
cb Value_
val'
withValue (ValueString String
str) Value_ -> IO a
cb =
    forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
str forall a b. (a -> b) -> a -> b
$ \Ptr CChar
str' -> forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
        forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
3
        forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' Ptr CChar
str'
        Value_ -> IO a
cb Value_
val'
withValue (ValueBool Bool
b) Value_ -> IO a
cb = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
    forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
4
    forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' Bool
b
    Value_ -> IO a
cb Value_
val'
withValue (ValueMatrix M22 Double
mat) Value_ -> IO a
cb =
    forall {a} {b}. Storable a => V2 (V2 a) -> (Ptr a -> IO b) -> IO b
withMatrix M22 Double
mat forall a b. (a -> b) -> a -> b
$ \Ptr Double
mat' -> forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
        forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
5
        forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' Ptr Double
mat'
        Value_ -> IO a
cb Value_
val'
withValue (ValueCharSet CharSet
charsets) Value_ -> IO a
cb =
    forall a. CharSet -> (Ptr CharSet' -> IO a) -> IO a
withCharSet CharSet
charsets forall a b. (a -> b) -> a -> b
$ \Ptr CharSet'
charsets' -> forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
        forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
6
        forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' Ptr CharSet'
charsets'
        Value_ -> IO a
cb Value_
val'
withValue (ValueFTFace FT_Face
x) Value_ -> IO a
cb = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
    forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
7
    forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' FT_Face
x
    Value_ -> IO a
cb Value_
val'
withValue (ValueLangSet LangSet
langset) Value_ -> IO a
cb =
    forall a. LangSet -> (Ptr LangSet' -> IO a) -> IO a
withLangSet LangSet
langset forall a b. (a -> b) -> a -> b
$ \Ptr LangSet'
langset' -> forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
        forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
8
        forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' Ptr LangSet'
langset'
        Value_ -> IO a
cb Value_
val'
withValue (ValueRange Range
range) Value_ -> IO a
cb =
    forall a. Range -> (Ptr Range' -> IO a) -> IO a
withRange Range
range forall a b. (a -> b) -> a -> b
$ \Ptr Range'
range' -> forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
value'Size forall a b. (a -> b) -> a -> b
$ \Value_
val' -> do
        forall a. Storable a => Ptr a -> a -> IO ()
poke Value_
val' Int
9
        forall {a} {a}. (Storable a, Storable a) => Ptr a -> a -> IO ()
pokeUnion Value_
val' Ptr Range'
range'
        Value_ -> IO a
cb Value_
val'

foreign import ccall "size_matrix" mat22Size :: Int
withMatrix :: V2 (V2 a) -> (Ptr a -> IO b) -> IO b
withMatrix (V2 (V2 a
xx a
yx) (V2 a
xy a
yy)) Ptr a -> IO b
cb = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
mat22Size forall a b. (a -> b) -> a -> b
$ \Ptr a
mat' -> do
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
mat' Int
0 a
xx
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
mat' Int
1 a
xy
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
mat' Int
2 a
yx
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
mat' Int
3 a
yy
    Ptr a -> IO b
cb Ptr a
mat'

thawValue :: Value_ -> IO (Maybe Value)
thawValue :: Value_ -> IO (Maybe Value)
thawValue Value_
ptr = do
    Word8
kind <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr Value_
ptr :: IO Word8
    let val' :: Ptr b
val' = forall a b. Ptr a -> Ptr b
castPtr (Value_
ptr forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int
1)
    case Word8
kind of
        Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Value
ValueVoid
        Word8
1 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Value
ValueInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
        Word8
2 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> Value
ValueDouble forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
        Word8
3 -> do
            Ptr CChar
val <- forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Value
ValueString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CChar -> IO String
peekCString Ptr CChar
val
        Word8
4 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Value
ValueBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
        Word8
5 -> do
            Ptr Double
mat' <- forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
            Double
xx <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Double
mat' Int
0
            Double
xy <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Double
mat' Int
1
            Double
yx <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Double
mat' Int
2
            Double
yy <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Double
mat' Int
3
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ M22 Double -> Value
ValueMatrix forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 (forall a. a -> a -> V2 a
V2 Double
xx Double
xy) (forall a. a -> a -> V2 a
V2 Double
yx Double
yy)
        Word8
6 -> do
            Ptr CharSet'
val <- forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharSet -> Value
ValueCharSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CharSet' -> IO CharSet
thawCharSet Ptr CharSet'
val
        Word8
7 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FT_Face -> Value
ValueFTFace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
        Word8
8 -> do
            Ptr LangSet'
val <- forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LangSet -> Value
ValueLangSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr LangSet' -> IO LangSet
thawLangSet Ptr LangSet'
val
        Word8
9 -> do
            Ptr Range'
val <- forall a. Ptr a -> Ptr a
throwNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek forall {b}. Ptr b
val'
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Value
ValueRange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Range' -> IO Range
thawRange Ptr Range'
val
        Word8
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing