module Graphics.Web.Processing.Mid.CustomVar (
CustomVar
, VarLength (..)
, CustomValue (..)
) where
import Data.Text (Text)
import Graphics.Web.Processing.Mid
import Graphics.Web.Processing.Core.Primal (varFromText)
import Control.Monad (liftM)
import GHC.Generics
data CustomVar a = CustomVar [Text] deriving Generic
class VarLength a => CustomValue a where
newVarC :: (Monad (m Preamble), ProcVarMonad m) => a -> m Preamble (CustomVar a)
default newVarC :: (Monad (m Preamble), ProcVarMonad m, Generic a, GCustomValue (Rep a))
=> a -> m Preamble (CustomVar a)
newVarC x = liftM castCVar $ gnewVarC (from x)
readVarC :: (Monad (m c), ProcVarMonad m) => CustomVar a -> m c a
default readVarC :: (Monad (m c), ProcVarMonad m, Generic a, GCustomValue (Rep a))
=> CustomVar a -> m c a
readVarC v = liftM to $ greadVarC (castCVar v)
writeVarC :: (Monad (m c), ProcVarMonad m) => CustomVar a -> a -> m c ()
default writeVarC :: (Monad (m c), ProcVarMonad m, Generic a, GCustomValue (Rep a)) => CustomVar a -> a -> m c ()
writeVarC v x = gwriteVarC (castCVar v) (from x)
fromVar :: Var a -> CustomVar a
fromVar = CustomVar . (:[]) . varName
fromCustomVar :: CustomVar a -> [Var a]
fromCustomVar (CustomVar xs) = fmap varFromText xs
instance CustomValue Proc_Bool where
newVarC = liftM fromVar . newVar
readVarC = readVar . head . fromCustomVar
writeVarC v x = writeVar (head $ fromCustomVar v) x
instance CustomValue Proc_Int where
newVarC = liftM fromVar . newVar
readVarC = readVar . head . fromCustomVar
writeVarC v x = writeVar (head $ fromCustomVar v) x
instance CustomValue Proc_Float where
newVarC = liftM fromVar . newVar
readVarC = readVar . head . fromCustomVar
writeVarC v x = writeVar (head $ fromCustomVar v) x
instance CustomValue Proc_Text where
newVarC = liftM fromVar . newVar
readVarC = readVar . head . fromCustomVar
writeVarC v x = writeVar (head $ fromCustomVar v) x
instance CustomValue Proc_Image where
newVarC = liftM fromVar . newVar
readVarC = readVar . head . fromCustomVar
writeVarC v x = writeVar (head $ fromCustomVar v) x
instance CustomValue Proc_Char where
newVarC = liftM fromVar . newVar
readVarC = readVar . head . fromCustomVar
writeVarC v x = writeVar (head $ fromCustomVar v) x
class VarLength a where
varLength :: a -> Int
varLength _ = 1
instance VarLength Proc_Bool where
instance VarLength Proc_Int where
instance VarLength Proc_Float where
instance VarLength Proc_Text where
instance VarLength Proc_Image where
instance VarLength Proc_Char where
class GVarLength f where
gvarLength :: f a -> Int
instance GVarLength U1 where
gvarLength _ = 1
instance (GVarLength a, GVarLength b) => GVarLength (a :*: b) where
gvarLength (a :*: b) = gvarLength a + gvarLength b
instance GVarLength (a :+: b) where
gvarLength _ = error "gvarLength: Custom variables cannot be sum types."
instance GVarLength a => GVarLength (M1 i c a) where
gvarLength (M1 x) = gvarLength x
instance VarLength a => GVarLength (K1 i a) where
gvarLength (K1 x) = varLength x
varDrop :: Int -> CustomVar a -> CustomVar a
varDrop n (CustomVar xs) = CustomVar $ drop n xs
castCVar :: CustomVar a -> CustomVar b
castCVar (CustomVar xs) = CustomVar xs
class GCustomValue f where
gnewVarC :: (Monad (m Preamble), ProcVarMonad m) => f a -> m Preamble (CustomVar (f a))
greadVarC :: (Monad (m c), ProcVarMonad m) => CustomVar (f a) -> m c (f a)
gwriteVarC :: (Monad (m c), ProcVarMonad m) => CustomVar (f a) -> f a -> m c ()
instance (GVarLength a, GCustomValue a, GCustomValue b) => GCustomValue (a :*: b) where
gnewVarC (a :*: b) = do
CustomVar xs <- gnewVarC a
CustomVar ys <- gnewVarC b
return $ CustomVar $ xs ++ ys
greadVarC v = do
a <- greadVarC $ castCVar v
let n = gvarLength a
b <- greadVarC $ varDrop n $ castCVar v
return $ a :*: b
gwriteVarC (CustomVar v) (a :*: b) = do
let (xs,ys) = splitAt (gvarLength a) v
gwriteVarC (CustomVar xs) a
gwriteVarC (CustomVar ys) b
instance GCustomValue (a :+: b) where
gnewVarC = error "gnewVarC: Custom variables cannot be sum types."
greadVarC = error "greadVarC: Custom variables cannot be sum types."
gwriteVarC = error "gwriteVarC: Custom variables cannot be sum types."
instance GCustomValue a => GCustomValue (M1 i c a) where
gnewVarC (M1 x) = liftM castCVar $ gnewVarC x
greadVarC v = liftM M1 $ greadVarC $ castCVar v
gwriteVarC v (M1 x) = gwriteVarC (castCVar v) x
instance CustomValue a => GCustomValue (K1 i a) where
gnewVarC (K1 x) = liftM castCVar $ newVarC x
greadVarC v = liftM K1 $ readVarC $ castCVar v
gwriteVarC v (K1 x) = writeVarC (castCVar v) x
instance (VarLength a, VarLength b) => VarLength (a,b)
instance (CustomValue a, CustomValue b) => CustomValue (a,b)
instance (VarLength a, VarLength b, VarLength c) => VarLength (a,b,c)
instance (CustomValue a, CustomValue b, CustomValue c) => CustomValue (a,b,c)