@@ -0,0 +1,91 @@
1+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators #-}
2+module ProjectM36.Tupleable where
3+import ProjectM36.Base
4+import ProjectM36.Atomable
5+import GHC.Generics
6+import qualified Data.Vector as V
7+import qualified Data.Text as T
8+import Data.Monoid
9+
10+data Test1T = Test1C {
11+ attrA :: Int
12+ }
13+ deriving (Generic)
14+
15+data Test2T = Test2C {
16+ attrB :: Int,
17+ attrC :: Int
18+ }
19+ deriving (Generic)
20+
21+data Test3T = Test3C Int
22+ deriving Generic
23+
24+data Test4T = Test4C
25+ deriving Generic
26+
27+data Test5T = Test5C1 Int |
28+ Test5C2 Int
29+ deriving Generic
30+
31+data Test6T = Test6C T.Text Int Double
32+ deriving Generic
33+
34+instance Tupleable Test1T
35+
36+instance Tupleable Test2T
37+
38+instance Tupleable Test3T
39+
40+instance Tupleable Test4T
41+
42+--instance Tupleable Test5T -- should fail at compile time- sum types not supported
43+
44+instance Tupleable Test6T
45+
46+class Tupleable a where
47+ toTuple :: a -> RelationTuple
48+
49+ default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
50+ toTuple v = toTupleG (from v)
51+
52+class TupleableG g where
53+ toTupleG :: g a -> RelationTuple
54+ toAttributesG :: g a -> Attributes
55+
56+--data type metadata
57+instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
58+ toTupleG (M1 v) = toTupleG v
59+ toAttributesG = undefined
60+
61+--constructor metadata
62+instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
63+ toTupleG (M1 v) = RelationTuple attrs atoms
64+ where
65+ attrsToCheck = toAttributesG v
66+ counter = V.generate (V.length attrsToCheck) id
67+ attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
68+ Attribute ("attr" <> (T.pack (show (num + 1)))) typ
69+ else
70+ attr) counter attrsToCheck
71+ atoms = V.fromList (toAtomsG v)
72+ toAttributesG = undefined
73+
74+-- product types
75+instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
76+ toTupleG = undefined
77+ toAttributesG (x :*: y) = toAttributesG x V.++ toAttributesG y
78+
79+--selector/record
80+instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
81+ toTupleG = undefined
82+ toAttributesG m@(M1 v) = V.singleton (Attribute name aType)
83+ where
84+ name = T.pack (selName m)
85+ aType = toAtomTypeG v
86+
87+--constructors with no arguments
88+--basically useless but orthoganal to relationTrue
89+instance TupleableG U1 where
90+ toTupleG = undefined
91+ toAttributesG _ = V.empty