From fe9a7c6d0af59227ff34b098f2a5ba1359790ae8 Mon Sep 17 00:00:00 2001
From: Csaba Hruska <csaba.hruska@gmail.com>
Date: Fri, 29 Jan 2016 15:27:53 +0100
Subject: add Schema to IR module, also use namespace

---
 lambdacube-ir.haskell/src/LambdaCube/IR.hs         |  1 +
 lambdacube-ir.haskell/src/LambdaCube/Linear.hs     | 60 ++++++++++++++++++++++
 lambdacube-ir.haskell/src/LambdaCube/Mesh.hs       |  1 +
 .../src/LambdaCube/PipelineSchema.hs               |  1 +
 .../src/LambdaCube/PipelineSchemaUtil.hs           | 20 ++++++++
 5 files changed, 83 insertions(+)
 create mode 120000 lambdacube-ir.haskell/src/LambdaCube/IR.hs
 create mode 100644 lambdacube-ir.haskell/src/LambdaCube/Linear.hs
 create mode 120000 lambdacube-ir.haskell/src/LambdaCube/Mesh.hs
 create mode 120000 lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs
 create mode 100644 lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs

(limited to 'lambdacube-ir.haskell/src/LambdaCube')

diff --git a/lambdacube-ir.haskell/src/LambdaCube/IR.hs b/lambdacube-ir.haskell/src/LambdaCube/IR.hs
new file mode 120000
index 0000000..7b90d33
--- /dev/null
+++ b/lambdacube-ir.haskell/src/LambdaCube/IR.hs
@@ -0,0 +1 @@
+../../../ddl/out/LambdaCube.IR.hs
\ No newline at end of file
diff --git a/lambdacube-ir.haskell/src/LambdaCube/Linear.hs b/lambdacube-ir.haskell/src/LambdaCube/Linear.hs
new file mode 100644
index 0000000..286cc93
--- /dev/null
+++ b/lambdacube-ir.haskell/src/LambdaCube/Linear.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveFunctor, OverloadedStrings #-}
+module LambdaCube.Linear where
+
+import Data.Int
+import Data.Word
+import Data.Map
+
+import Data.Text
+import Data.Aeson
+import Control.Monad
+
+data V2 a = V2 !a !a deriving (Eq,Ord,Show,Read,Functor)
+data V3 a = V3 !a !a !a deriving (Eq,Ord,Show,Read,Functor)
+data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show,Read,Functor)
+
+-- matrices are stored in column major order
+type M22F = V2 V2F
+type M23F = V3 V2F
+type M24F = V4 V2F
+type M32F = V2 V3F
+type M33F = V3 V3F
+type M34F = V4 V3F
+type M42F = V2 V4F
+type M43F = V3 V4F
+type M44F = V4 V4F
+
+type V2F = V2 Float
+type V3F = V3 Float
+type V4F = V4 Float
+type V2I = V2 Int32
+type V3I = V3 Int32
+type V4I = V4 Int32
+type V2U = V2 Word32
+type V3U = V3 Word32
+type V4U = V4 Word32
+type V2B = V2 Bool
+type V3B = V3 Bool
+type V4B = V4 Bool
+
+instance ToJSON a => ToJSON (V2 a) where
+  toJSON (V2 x y) = object ["x" .= x, "y" .= y]
+
+instance ToJSON a => ToJSON (V3 a) where
+  toJSON (V3 x y z) = object ["x" .= x, "y" .= y, "z" .= z]
+
+instance ToJSON a => ToJSON (V4 a) where
+  toJSON (V4 x y z w) = object ["x" .= x, "y" .= y, "z" .= z, "w" .= w]
+
+instance FromJSON a => FromJSON (V2 a) where
+  parseJSON (Object obj) = V2 <$> obj .: "x" <*> obj .: "y"
+  parseJSON _ = mzero
+
+instance FromJSON a => FromJSON (V3 a) where
+  parseJSON (Object obj) = V3 <$> obj .: "x" <*> obj .: "y" <*> obj .: "z"
+  parseJSON _ = mzero
+
+instance FromJSON a => FromJSON (V4 a) where
+  parseJSON (Object obj) = V4 <$> obj .: "x" <*> obj .: "y" <*> obj .: "z" <*> obj .: "w"
+  parseJSON _ = mzero
+
diff --git a/lambdacube-ir.haskell/src/LambdaCube/Mesh.hs b/lambdacube-ir.haskell/src/LambdaCube/Mesh.hs
new file mode 120000
index 0000000..9dfc009
--- /dev/null
+++ b/lambdacube-ir.haskell/src/LambdaCube/Mesh.hs
@@ -0,0 +1 @@
+../../../ddl/out/LambdaCube.Mesh.hs
\ No newline at end of file
diff --git a/lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs
new file mode 120000
index 0000000..afe52ef
--- /dev/null
+++ b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs
@@ -0,0 +1 @@
+../../../ddl/out/LambdaCube.PipelineSchema.hs
\ No newline at end of file
diff --git a/lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs
new file mode 100644
index 0000000..a5eac55
--- /dev/null
+++ b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+module LambdaCube.PipelineSchemaUtil where
+
+import Control.Monad.Writer
+import qualified Data.Map as Map
+import LambdaCube.PipelineSchema
+
+a @: b = tell [(a,b)]
+defObjectArray n p m = mapM_ tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.singleton a t) mempty | (a,t) <- execWriter m]
+defUniforms m = tell $ PipelineSchema mempty $ Map.fromList $ execWriter m
+makeSchema a = execWriter a :: PipelineSchema
+
+unionObjectArraySchema (ObjectArraySchema a1 b1) (ObjectArraySchema a2 b2) =
+  ObjectArraySchema (if a1 == a2 then a1 else error $ "object array schema primitive mismatch " ++ show (a1,a2))
+                    (Map.unionWith (\a b -> if a == b then a else error $ "object array schema attribute type mismatch " ++ show (a,b)) b1 b2)
+
+instance Monoid PipelineSchema where
+  mempty = PipelineSchema mempty mempty
+  mappend (PipelineSchema a1 b1) (PipelineSchema a2 b2) =
+    PipelineSchema (Map.unionWith unionObjectArraySchema a1 a2) (Map.unionWith (\a b -> if a == b then a else error $ "schema type mismatch " ++ show (a,b)) b1 b2)
-- 
cgit v1.2.3