module Shady.Language.Type
(
ScalarT(..), VectorT(..), Type(..)
, TextureId, Sampler(..), sampler1, sampler2, sampler3, Sampler1, Sampler2, Sampler3
, IsScalar(..), vectorT, HasType(..)
, typeOf, typeOf1, typeOf2, compatible, compatible1
, IsVec(..),checkVec, checkVec'
, (:=:)(..), ptyEq, vtyEq, tyEq
, (=:=), (===)
, R, R1, R2, R3, R4, B1, Pred1, Pred2
, SynEq(..),SynEq2(..)
, PairF(..), (:#), UnitF(..)
, module Shady.Vec
) where
import Control.Applicative (pure,liftA2,Const(..))
import Data.Maybe (isJust)
import Data.List (intercalate)
import Control.Monad.Instances ()
import Foreign.Storable
import Data.Typeable (Typeable)
import Text.PrettyPrint.Leijen
import Text.PrettyPrint.Leijen.PrettyPrec
import Text.PrettyPrint.Leijen.DocExpr
import Shady.Misc (FMod(..),R)
import Shady.Vec
import Data.Proof.EQ
data ScalarT :: * -> * where
Bool :: ScalarT Bool
Int :: ScalarT Int
Float :: ScalarT Float
instance Show (ScalarT a) where
show Bool = "bool"
show Int = "int"
show Float = "float"
instance HasExprU ScalarT where
exprU Bool = var "bool"
exprU Int = var "int"
exprU Float = var "float"
instance Pretty (ScalarT a) where pretty = text . show
vshow :: Show a => a -> Expr
vshow = var . show
instance HasExpr (ScalarT a) where expr = vshow
data VectorT n a = VectorT (Nat n) (ScalarT a)
instance Show (VectorT n a) where
show (VectorT n t) = showVectorN (natToZ n) t
instance HasExprU (VectorT n) where exprU = expr
instance HasExpr (VectorT n a) where expr = var . show
showVectorN :: Integer -> ScalarT a -> String
showVectorN 1 p = show p
showVectorN n p = pref p ++ "vec" ++ show n
where
pref :: ScalarT b -> String
pref Bool = "b"
pref Int = "i"
pref Float = ""
instance Pretty (VectorT n a) where pretty = text . show
type TextureId = Int
data Sampler n =
Sampler { samplerDim :: Nat n, samplerTexture :: TextureId }
type Sampler1 = Sampler OneT
type Sampler2 = Sampler TwoT
type Sampler3 = Sampler ThreeT
instance Show (Sampler n) where
show (Sampler n tex) = "<Sampler "++show n++" "++show tex++">"
instance Pretty (Sampler n) where
pretty = text . show
sampler1 :: TextureId -> Sampler1
sampler1 = Sampler one
sampler2 :: TextureId -> Sampler2
sampler2 = Sampler two
sampler3 :: TextureId -> Sampler3
sampler3 = Sampler three
data Type :: * -> * where
VecT :: (IsNat n, IsScalar a ) =>
VectorT n a -> Type (Vec n a)
SamplerT :: IsNat n => Nat n -> Type (Sampler n)
UnitT :: Type ()
(:*:) :: (HasType a, HasType b ) =>
Type a -> Type b -> Type (a , b)
(:->:) :: (HasType a, HasType b ) =>
Type a -> Type b -> Type (a -> b)
instance HasExpr (Type t) where
expr (VecT t) = expr t
expr (SamplerT n) = var $ "sampler" ++ show n ++ "D"
expr UnitT = var "()"
expr (a :*: b) = op InfixR 1 ":*" (expr a) (expr b)
expr (a :->: b) = op InfixR 0 "->" (expr a) (expr b)
instance HasExprU Type where exprU = expr
instance PrettyPrec (Type t) where prettyPrec = prettyExpr
instance Pretty (Type t) where pretty = prettyPrec 0
instance Show (Type t) where show = show . expr
class (Storable a, Typeable a, Show a) => IsScalar a where scalarT :: ScalarT a
instance IsScalar Bool where scalarT = Bool
instance IsScalar Int where scalarT = Int
instance IsScalar Float where scalarT = Float
vectorT :: (IsNat n, IsScalar a) => VectorT n a
vectorT = VectorT nat scalarT
class Show t => HasType t where typeT :: Type t
instance (IsNat n, IsScalar a ) =>
HasType (Vec n a) where
typeT = VecT vectorT
instance HasType () where typeT = UnitT
instance (HasType a, HasType b ) =>
HasType (a, b) where typeT = typeT :*: typeT
instance (HasType a, HasType b ) =>
HasType (a->b) where typeT = typeT :->: typeT
instance IsNat n => HasType (Sampler n) where
typeT = SamplerT nat
typeOf :: HasType a => a -> Type a
typeOf = const typeT
typeOf1 :: HasType a => f a -> Type a
typeOf1 = const typeT
typeOf2 :: HasType a => g (f a) -> Type a
typeOf2 = const typeT
data IsVec :: * -> * where
IsVec :: (IsNat n, IsScalar a) => IsVec (Vec n a)
checkVec :: forall t. HasType t => Maybe (IsVec t)
checkVec =
case (typeT :: Type t) of
VecT _ -> Just IsVec
_ -> Nothing
checkVec' :: forall f t. HasType t => f t -> Maybe (IsVec t)
checkVec' = const checkVec
ptyEq :: ScalarT a -> ScalarT b -> Maybe (a :=: b)
ptyEq Bool Bool = Just Refl
ptyEq Int Int = Just Refl
ptyEq Float Float = Just Refl
ptyEq _ _ = Nothing
vtyEq :: VectorT m a -> VectorT n b -> Maybe (Vec m a :=: Vec n b)
vtyEq (VectorT m a) (VectorT n b) = liftA2 liftEq2 (m `natEq` n) (a `ptyEq` b)
tyEq :: Type c -> Type c' -> Maybe (c :=: c')
tyEq (VecT a) (VecT a') = vtyEq a a'
tyEq (SamplerT n) (SamplerT n') = fmap liftEq (natEq n n')
tyEq UnitT UnitT = Just Refl
tyEq (a :*: b) (a' :*: b') = liftA2 liftEq2 (tyEq a a') (tyEq b b')
tyEq (a :->: b) (a' :->: b') = liftA2 liftEq2 (tyEq a a') (tyEq b b')
tyEq _ _ = Nothing
(=:=) :: forall f a b. (HasType a, HasType b, SynEq f) =>
f a -> f b -> Maybe (a :=: b)
fa =:= fb =
case typeOf1 fa `tyEq` typeOf1 fb of
Just Refl -> if fa =-= fb then Just Refl else Nothing
Nothing -> Nothing
(===) :: forall f a b. (HasType a, HasType b, SynEq f) =>
f a -> f b -> Bool
fa === fb = isJust (fa =:= fb)
compatible :: (HasType a, HasType b) => a -> b -> Maybe (a :=: b)
x `compatible` y = typeOf x `tyEq` typeOf y
compatible1 :: (HasType a, HasType b) => f a -> g b -> Maybe (a :=: b)
x `compatible1` y = typeOf1 x `tyEq` typeOf1 y
type R1 = One R
type R2 = Two R
type R3 = Three R
type R4 = Four R
type B1 = One Bool
type Pred1 a = a -> B1
type Pred2 a = a -> Pred1 a
infix 4 =-=, =--=
class SynEq f where
(=-=) :: HasType c => f c -> f c -> Bool
instance Eq x => SynEq (Const x) where (=-=) = (==)
class SynEq2 f where
(=--=) :: (SynEq v, HasType c) => f v c -> f v c -> Bool
deriving instance Eq a => Eq (Const a b)
infixr 1 #, :#
class PairF f where
(#) :: (HasType a, HasType b ) =>
f a -> f b -> f (a :# b)
type a :# b = (a,b)
class UnitF f where unit :: f ()
instance (IsNat n, IsScalar a, Pretty a) => Pretty (Vec n a) where
pretty v | n == 1 = pretty (head as)
| otherwise = pretty (vectorT :: VectorT n a) <> tupled (map pretty as)
where as = vElems v
n = length as
instance (IsNat n, IsScalar a, Show a) => Show (Vec n a) where
show v | n == 1 = show (head as)
| otherwise = show (vectorT :: VectorT n a)
++ "(" ++ intercalate "," (map show as) ++ ")"
where as = vElems v
n = length as
instance (IsNat n, IsScalar a, Pretty a) => PrettyPrec (Vec n a)
instance (IsNat n, IsScalar a, Show a) => HasExpr (Vec n a)
#define INSTANCE_Enum
#define CONSTRAINTS IsNat n, IsScalar applicative_arg,
#define APPLICATIVE (Vec n)
#include "ApplicativeNumeric-inc.hs"
instance (IsNat n, IsScalar a, FMod a) => FMod (Vec n a) where
fmod = liftA2 fmod