{-# 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 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 (throwNull)

data Value = ValueVoid
    | ValueInt Int
    | ValueDouble Double
    | ValueString String
    | ValueBool Bool
    | ValueMatrix (M22 Double)
    | ValueCharSet CharSet
    | ValueFTFace FT_Face
    | ValueLangSet LangSet
    | ValueRange Range deriving (Eq, Show, Ord, Generic)

instance Hashable Value

class ToValue x where
    toValue :: x -> Value

instance ToValue () where
    toValue () = ValueVoid
instance ToValue Int where
    toValue = ValueInt
instance ToValue Double where
    toValue = ValueDouble
instance ToValue String where
    toValue = ValueString
instance ToValue Bool where
    toValue = ValueBool
instance ToValue (M22 Double) where
    toValue = ValueMatrix
instance ToValue CharSet where
    toValue = ValueCharSet
instance ToValue FT_Face where
    toValue = ValueFTFace
instance ToValue LangSet where
    toValue = ValueLangSet
instance ToValue Range where
    toValue = ValueRange

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

type Value_ = Ptr Int

foreign import ccall "size_value" value'Size :: Int
pokeUnion ptr x = castPtr (ptr `advancePtr` 1) `poke` x

withValue :: Value -> (Value_ -> IO a) -> IO a
withValue ValueVoid cb = allocaBytes value'Size $ \val' -> do
    poke val' 0
    cb val'
withValue (ValueInt x) cb = allocaBytes value'Size $ \val' -> do
    poke val' 1
    pokeElemOff val' 1 x
    cb val'
withValue (ValueDouble x) cb = allocaBytes value'Size $ \val' -> do
    poke val' 2
    pokeUnion val' x
    cb val'
withValue (ValueString str) cb =
    withCString str $ \str' -> allocaBytes value'Size $ \val' -> do
        poke val' 3
        pokeUnion val' str'
        cb val'
withValue (ValueBool b) cb = allocaBytes value'Size $ \val' -> do
    poke val' 4
    pokeUnion val' b
    cb val'
withValue (ValueMatrix mat) cb =
    withMatrix mat $ \mat' -> allocaBytes value'Size $ \val' -> do
        poke val' 5
        pokeUnion val' mat'
        cb val'
withValue (ValueCharSet charsets) cb =
    withCharSet charsets $ \charsets' -> allocaBytes value'Size $ \val' -> do
        poke val' 6
        pokeUnion val' charsets'
        cb val'
withValue (ValueFTFace x) cb = allocaBytes value'Size $ \val' -> do
    poke val' 7
    pokeUnion val' x
    cb val'
withValue (ValueLangSet langset) cb =
    withLangSet langset $ \langset' -> allocaBytes value'Size $ \val' -> do
        poke val' 8
        pokeUnion val' langset'
        cb val'
withValue (ValueRange range) cb =
    withRange range $ \range' -> allocaBytes value'Size $ \val' -> do
        poke val' 9
        pokeUnion val' range'
        cb val'

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

thawValue :: Value_ -> IO (Maybe Value)
thawValue ptr = do
    kind <- peek ptr
    let val' = castPtr (ptr `advancePtr` 1)
    case kind of
        0 -> return $ Just ValueVoid
        1 -> Just <$> ValueInt <$> peek val'
        2 -> Just <$> ValueDouble <$> peek val'
        3 -> do
            val <- throwNull <$> peek val'
            Just <$> ValueString <$> peekCString val
        4 -> Just <$> ValueBool <$> peek val'
        5 -> do
            mat' <- throwNull <$> peek val'
            xx <- peekElemOff mat' 0
            xy <- peekElemOff mat' 1
            yx <- peekElemOff mat' 2
            yy <- peekElemOff mat' 3
            return $ Just $ ValueMatrix $ V2 (V2 xx xy) (V2 yx yy)
        6 -> do
            val <- throwNull <$> peek val'
            Just <$> ValueCharSet <$> thawCharSet val
        7 -> Just <$> ValueFTFace <$> throwNull <$> peek val'
        8 -> do
            val <- throwNull <$> peek val'
            Just <$> ValueLangSet <$> thawLangSet val
        9 -> do
            val <- throwNull <$> peek val'
            Just <$> ValueRange <$> thawRange val
        _ -> return Nothing