git.iko.soy/project-m36
on master help sign in
non-compiling tupleable implementation
42746d8AgentM
project-m36.cabal+10
compare with master
unifiedsplit
@@ -491,3 +491,13 @@ Test-Suite test-transactiongraph-automerge
491 GHC-Options: -Wall
491 GHC-Options: -Wall
492 Hs-Source-Dirs: ./src/bin, ., test/
492 Hs-Source-Dirs: ./src/bin, ., test/
493 CPP-Options: -DPROJECTM36_VERSION="v0.1"
493 CPP-Options: -DPROJECTM36_VERSION="v0.1"
494+
495+Test-Suite test-tupleable
496+ Default-Language: Haskell2010
497+ type: exitcode-stdio-1.0
498+ main-is: test/Relation/Tupleable.hs
499+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36, random, MonadRandom, semigroups
500+ Default-Extensions: OverloadedStrings
501+ GHC-Options: -Wall
502+ Hs-Source-Dirs: ./src/bin, ., test/
503+ CPP-Options: -DPROJECTM36_VERSION="v0.1"
src/lib/ProjectM36/Tupleable.hs+45−34
@@ -1,62 +1,60 @@
1−{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators #-}
1+{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances #-}
2module ProjectM36.Tupleable where
2module ProjectM36.Tupleable where
3import ProjectM36.Base
3import ProjectM36.Base
4+import ProjectM36.Tuple
4import ProjectM36.Atomable
5import ProjectM36.Atomable
6+import ProjectM36.Attribute
5import GHC.Generics
7import GHC.Generics
6import qualified Data.Vector as V
8import qualified Data.Vector as V
7import qualified Data.Text as T
9import qualified Data.Text as T
8import Data.Monoid
10import Data.Monoid
9−
11+import Data.Proxy
12+import Data.Maybe
13+import ProjectM36.DataTypes.Primitive
14+import Debug.Trace
15+
10data Test1T = Test1C {
16data Test1T = Test1C {
11 attrA :: Int
17 attrA :: Int
12 }
18 }
13− deriving (Generic)
19+ deriving (Generic, Show)
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
20
24−data Test4T = Test4C
21+data Test2T a b = Test2C {
25− deriving Generic
22+ attrB :: a,
26−
23+ attrC :: b
27−data Test5T = Test5C1 Int |
24+ }
28− Test5C2 Int
29− deriving Generic
30−
31−data Test6T = Test6C T.Text Int Double
32− deriving Generic
25+ deriving (Generic, Show)
33
26
34−instance Tupleable Test1T
27+instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
35−
36−instance Tupleable Test2T
37
28
38−instance Tupleable Test3T
29+instance Tupleable Test1T
39−
40−instance Tupleable Test4T
41
30
42−--instance Tupleable Test5T -- should fail at compile time- sum types not supported
43
31
44−instance Tupleable Test6T
45−
46class Tupleable a where
32class Tupleable a where
47 toTuple :: a -> RelationTuple
33 toTuple :: a -> RelationTuple
34+
35+ fromTuple :: RelationTuple -> a
36+
37+ toAttributes :: a -> Attributes
48
38
49 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
39 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
50 toTuple v = toTupleG (from v)
40 toTuple v = toTupleG (from v)
51
41
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+
52class TupleableG g where
48class TupleableG g where
53 toTupleG :: g a -> RelationTuple
49 toTupleG :: g a -> RelationTuple
54 toAttributesG :: g a -> Attributes
50 toAttributesG :: g a -> Attributes
51+ fromTupleG :: RelationTuple -> g a
55
52
56--data type metadata
53--data type metadata
57instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
54instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
58 toTupleG (M1 v) = toTupleG v
55 toTupleG (M1 v) = toTupleG v
59 toAttributesG = undefined
56 toAttributesG = undefined
57+ fromTupleG v = M1 (fromTupleG v)
60
58
61--constructor metadata
59--constructor metadata
62instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
60instance (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
65 attrsToCheck = toAttributesG v
63 attrsToCheck = toAttributesG v
66 counter = V.generate (V.length attrsToCheck) id
64 counter = V.generate (V.length attrsToCheck) id
67 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
65 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
69 else
67 else
70 attr) counter attrsToCheck
68 attr) counter attrsToCheck
71 atoms = V.fromList (toAtomsG v)
69 atoms = V.fromList (toAtomsG v)
72− toAttributesG = undefined
70+ toAttributesG = undefined
71+ fromTupleG tup = M1 (fromTupleG tup)
73
72
74-- product types
73-- product types
75instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
74instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
76 toTupleG = undefined
75 toTupleG = undefined
77 toAttributesG (x :*: y) = toAttributesG x V.++ toAttributesG y
76 toAttributesG (x :*: y) = toAttributesG x V.++ toAttributesG y
77+ fromTupleG = undefined
78
78
79--selector/record
79--selector/record
80instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
80instance (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
83 where
83 where
84 name = T.pack (selName m)
84 name = T.pack (selName m)
85 aType = toAtomTypeG v
85 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+
87--constructors with no arguments
97--constructors with no arguments
88--basically useless but orthoganal to relationTrue
98--basically useless but orthoganal to relationTrue
89instance TupleableG U1 where
99instance TupleableG U1 where
90 toTupleG = undefined
100 toTupleG = undefined
91− toAttributesG _ = V.empty
101+ toAttributesG _ = emptyAttributes
102+ fromTupleG = undefined
test/Relation/Tupleable.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# LANGUAGE DeriveGeneric, DefaultSignatures, FlexibleInstances, FlexibleContexts, TypeOperators #-}
2+import Test.HUnit
3+import ProjectM36.Tupleable
4+import ProjectM36.Base
5+import TutorialD.Interpreter.TestBase
6+import GHC.Generics
7+
8+data Test1T = Test1C {
9+ attrA :: Int
10+ }
11+ deriving (Generic)
12+
13+data Test2T = Test2C {
14+ attrB :: Int,
15+ attrC :: Int
16+ }
17+ deriving (Generic)
18+
19+data Test3T = Test3C Int
20+ deriving Generic
21+
22+data Test4T = Test4C
23+ deriving Generic
24+
25+data Test5T = Test5C1 Int |
26+ Test5C2 Int
27+ deriving Generic
28+
29+data Test6T = Test6C T.Text Int Double
30+ deriving Generic
31+
32+instance Tupleable Test1T
33+
34+instance Tupleable Test2T
35+
36+instance Tupleable Test3T
37+
38+instance Tupleable Test4T
39+
40+--instance Tupleable Test5T -- should fail at compile time- sum types not supported
41+
42+instance Tupleable Test6T
43+
44+main :: IO ()
45+main = do
46+ tcounts <- runTestTT testList
47+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
48+
49+testList :: Test
50+testList = TestList [testADT1]
51+
52+testADT1 :: Test
53+testADT1 = TestCase $ do
54+ let example = Test1C {attr1 = 3}
55+ assertEqual "one arg constructor" example (fromTuple (toTuple example))