blob: dc2c456e65b2925ed4f4d5987b1edf8ccfe3c4f9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
{-# LANGUAGE CPP, 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
#if !MIN_VERSION_base(4,11,0)
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)
#else
instance Semigroup PipelineSchema where
(<>) (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)
#endif
|
