@@ -1,62 +1,60 @@
1−{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators #-}
1+{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances #-}
22module ProjectM36.Tupleable where
33import ProjectM36.Base
4+import ProjectM36.Tuple
45import ProjectM36.Atomable
6+import ProjectM36.Attribute
57import GHC.Generics
68import qualified Data.Vector as V
79import qualified Data.Text as T
810import Data.Monoid
9−
11+import Data.Proxy
12+import Data.Maybe
13+import ProjectM36.DataTypes.Primitive
14+import Debug.Trace
15+
1016data Test1T = Test1C {
1117 attrA :: Int
1218 }
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
19+ deriving (Generic, Show)
2320
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
21+data Test2T a b = Test2C {
22+ attrB :: a,
23+ attrC :: b
24+ }
25+ deriving (Generic, Show)
3326
34−instance Tupleable Test1T
35−
36−instance Tupleable Test2T
27+instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
3728
38−instance Tupleable Test3T
39−
40−instance Tupleable Test4T
29+instance Tupleable Test1T
4130
42−--instance Tupleable Test5T -- should fail at compile time- sum types not supported
4331
44−instance Tupleable Test6T
45−
4632class Tupleable a where
4733 toTuple :: a -> RelationTuple
34+
35+ fromTuple :: RelationTuple -> a
36+
37+ toAttributes :: a -> Attributes
4838
4939 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
5040 toTuple v = toTupleG (from v)
5141
42+ default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> a
43+ fromTuple tup = to (fromTupleG tup)
44+
45+ default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes
46+ toAttributes v = toAttributesG (from v)
47+
5248class TupleableG g where
5349 toTupleG :: g a -> RelationTuple
5450 toAttributesG :: g a -> Attributes
51+ fromTupleG :: RelationTuple -> g a
5552
5653--data type metadata
5754instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
5855 toTupleG (M1 v) = toTupleG v
5956 toAttributesG = undefined
57+ fromTupleG v = M1 (fromTupleG v)
6058
6159--constructor metadata
6260instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
@@ -65,16 +63,18 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe
6563 attrsToCheck = toAttributesG v
6664 counter = V.generate (V.length attrsToCheck) id
6765 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
68− Attribute ("attr" <> (T.pack (show (num + 1)))) typ
66+ Attribute ("attr" <> T.pack (show (num + 1))) typ
6967 else
7068 attr) counter attrsToCheck
7169 atoms = V.fromList (toAtomsG v)
72− toAttributesG = undefined
70+ toAttributesG = undefined
71+ fromTupleG tup = M1 (fromTupleG tup)
7372
7473-- product types
7574instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
7675 toTupleG = undefined
7776 toAttributesG (x :*: y) = toAttributesG x V.++ toAttributesG y
77+ fromTupleG = undefined
7878
7979--selector/record
8080instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
@@ -83,9 +83,20 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
8383 where
8484 name = T.pack (selName m)
8585 aType = toAtomTypeG v
86−
86+ fromTupleG tup = case atomForAttributeName (T.pack name) tup of
87+ Left _ -> error "no such record name"
88+ Right atom -> M1 (atomv atom)
89+ where
90+ atomv atom = case fromAtomG atom [atom] of
91+ Nothing -> error "no such atom conversion"
92+ Just v -> v
93+ name = selName (undefined :: M1 S c a x)
94+ --name = "attrA"
95+
96+
8797--constructors with no arguments
8898--basically useless but orthoganal to relationTrue
8999instance TupleableG U1 where
90100 toTupleG = undefined
91− toAttributesG _ = V.empty
101+ toAttributesG _ = emptyAttributes
102+ fromTupleG = undefined