module Graphics.Web.Processing.Mid.CustomVar (
CustomVar
, CustomArrayVar
, customArraySize
, VarLength (..)
, CustomValue (..)
, readArrayVarC
, writeArrayVarC
) where
import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import Text.PrettyPrint.Mainland (ppr, prettyLazyText)
import Data.Monoid ((<>))
import Graphics.Web.Processing.Mid
import Graphics.Web.Processing.Core.Primal (varFromText,Proc_Int (..))
import Control.Monad (liftM)
import GHC.Generics
import Graphics.Web.Processing.Core.TH
data CustomVar a = CustomVar [Text] deriving Generic
mapCustomVar :: (Text -> Text) -> CustomVar a -> CustomVar a
mapCustomVar f (CustomVar xs) = CustomVar (fmap f xs)
class VarLength a => CustomValue a where
newVarC :: (Monad (m Preamble), ProcMonad m) => a -> m Preamble (CustomVar a)
default newVarC :: (Monad (m Preamble), ProcMonad m, Generic a, GCustomValue (Rep a))
=> a -> m Preamble (CustomVar a)
newVarC = liftM castCVar . gnewVarC . from
newArrayVarC :: (Monad (m Preamble), ProcMonad m) => [a] -> m Preamble (CustomArrayVar a)
default newArrayVarC :: (Monad (m Preamble), ProcMonad m, Generic a, GCustomValue (Rep a))
=> [a] -> m Preamble (CustomArrayVar a)
newArrayVarC = liftM castCAVar . gnewArrayVarC . fmap from
readVarC :: (Monad (m c), ProcMonad m) => CustomVar a -> m c a
default readVarC :: (Monad (m c), ProcMonad m, Generic a, GCustomValue (Rep a))
=> CustomVar a -> m c a
readVarC v = liftM to $ greadVarC (castCVar v)
writeVarC :: (Monad (m c), ProcMonad m) => CustomVar a -> a -> m c ()
default writeVarC :: (Monad (m c), ProcMonad m, Generic a, GCustomValue (Rep a)) => CustomVar a -> a -> m c ()
writeVarC v x = gwriteVarC (castCVar v) (from x)
ifC :: Proc_Bool -> a -> a -> a
default ifC :: (Generic a, GCustomValue (Rep a)) => Proc_Bool -> a -> a -> a
ifC b x y = to $ gifC b (from x) (from y)
arrayVarToVarC :: CustomArrayVar a -> Proc_Int -> CustomVar a
arrayVarToVarC v n = mapCustomVar f $ customInnerVar v
where
f t = t <> "[" <> (toStrict $ prettyLazyText 80 $ ppr n) <> "]"
readArrayVarC :: (ProcMonad m, Monad (m c), CustomValue a)
=> CustomArrayVar a -> Proc_Int -> m c a
readArrayVarC v n =
case n of
Proc_Int i -> let s = customArraySize v
in if (i < 0) || (i >= s)
then fail $ "readArrayVarC: index out of bounds.\nArray size: "
++ show s
++ ".\nIndex given: "
++ show i
++ ".\nRemember that indices start from 0."
else readVarC $ arrayVarToVarC v n
_ -> readVarC $ arrayVarToVarC v n
writeArrayVarC :: (ProcMonad m, Monad (m c), CustomValue a)
=> CustomArrayVar a -> Proc_Int -> a -> m c ()
writeArrayVarC v n x = writeVarC (arrayVarToVarC v n) x
fromVar :: Var a -> CustomVar a
fromVar = CustomVar . (:[]) . varName
fromCustomVar :: CustomVar a -> [Var a]
fromCustomVar (CustomVar xs) = fmap varFromText xs
data CustomArrayVar a =
CustomArrayVar {
customArraySize :: Int
, customInnerVar :: CustomVar a
}
fromArrayVar :: ArrayVar a -> CustomArrayVar a
fromArrayVar v =
CustomArrayVar (arraySize v) $ fromVar $ varFromText $ arrayVarName v
class VarLength a where
varLength :: a -> Int
default varLength :: (Generic a, GVarLength (Rep a)) => a -> Int
varLength = gvarLength . from
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 contain 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
castCAVar :: CustomArrayVar a -> CustomArrayVar b
castCAVar (CustomArrayVar n v) = CustomArrayVar n $ castCVar v
class GCustomValue f where
gnewVarC :: (Monad (m Preamble), ProcMonad m) => f a -> m Preamble (CustomVar (f a))
gnewArrayVarC :: (Monad (m Preamble), ProcMonad m) => [f a] -> m Preamble (CustomArrayVar (f a))
greadVarC :: (Monad (m c), ProcMonad m) => CustomVar (f a) -> m c (f a)
gwriteVarC :: (Monad (m c), ProcMonad m) => CustomVar (f a) -> f a -> m c ()
gifC :: Proc_Bool -> f a -> f a -> f a
leftP :: (a :*: b) c -> a c
leftP (a :*: _) = a
rightP :: (a :*: b) c -> b c
rightP (_ :*: b) = b
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
gnewArrayVarC l = do
let as = fmap leftP l
bs = fmap rightP l
CustomArrayVar n (CustomVar xs) <- gnewArrayVarC as
CustomArrayVar _ (CustomVar ys) <- gnewArrayVarC bs
return $ CustomArrayVar n $ 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
gifC c (a :*: b) (x :*: y) = gifC c a x :*: gifC c b y
instance GCustomValue (a :+: b) where
gnewVarC = error "gnewVarC: Custom variables cannot contain sum types."
gnewArrayVarC = error "gnewArrayVarC: Custom variables cannot contain sum types."
greadVarC = error "greadVarC: Custom variables cannot contain sum types."
gwriteVarC = error "gwriteVarC: Custom variables cannot contain sum types."
gifC = error "gifC: Custom values are not sum types."
instance GCustomValue a => GCustomValue (M1 i c a) where
gnewVarC (M1 x) = liftM castCVar $ gnewVarC x
gnewArrayVarC = liftM castCAVar . gnewArrayVarC . fmap unM1
greadVarC v = liftM M1 $ greadVarC $ castCVar v
gwriteVarC v (M1 x) = gwriteVarC (castCVar v) x
gifC b (M1 x) (M1 y) = M1 $ gifC b x y
instance CustomValue a => GCustomValue (K1 i a) where
gnewVarC (K1 x) = liftM castCVar $ newVarC x
gnewArrayVarC = liftM castCAVar . newArrayVarC . fmap unK1
greadVarC v = liftM K1 $ readVarC $ castCVar v
gwriteVarC v (K1 x) = writeVarC (castCVar v) x
gifC b (K1 x) (K1 y) = K1 $ ifC b x y
$(deriveCustomValues)
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)