@@ -3,11 +3,10 @@ module ProjectM36.ConstructedAtom where
33--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data
44--instances to marshal Haskell ADTs to ConstructedAtoms and back
55import ProjectM36.Base
6+import ProjectM36.DataTypes.Primitive
67import GHC.Generics
78import qualified Data.Text as T
89import qualified Data.Map as M
9−--import Data.Typeable
10−--import Debug.Trace
1110
1211data TestT = TestC Int
1312 deriving (Generic, Show, Eq)
@@ -27,10 +26,9 @@ data TyTest a = TyTest a
2726instance Atomable TestT
2827instance Atomable a => Atomable (Test2T a)
2928instance Atomable Test3T
30−--instance Atomable Test4T
29+instance Atomable Test4T
3130
3231class (Eq a, Show a) => Atomable a where
33− --type AtomT a
3432 toAtom :: a -> Atom
3533 default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom
3634 toAtom v = toAtomG (from v) (toAtomTypeG (from v))
@@ -39,13 +37,20 @@ class (Eq a, Show a) => Atomable a where
3937 default toAtomType :: (Generic a, AtomableG (Rep a)) => a -> AtomType
4038 toAtomType v = toAtomTypeG (from v)
4139
40+ --creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database
41+ toDatabaseContextExpr :: a -> DatabaseContextExpr
42+ default toDatabaseContextExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr
43+ toDatabaseContextExpr v = toDatabaseContextExprG (from v) (toAtomType v)
44+
4245instance Atomable Int where
4346 toAtom i = IntAtom i
4447 toAtomType _ = IntAtomType
48+ toDatabaseContextExpr _ = NoOperation
4549
4650instance Atomable T.Text where
4751 toAtom i = TextAtom i
4852 toAtomType _ = TextAtomType
53+ toDatabaseContextExpr _ = NoOperation
4954
5055-- Generics
5156class AtomableG g where
@@ -53,49 +58,93 @@ class AtomableG g where
5358 toAtomG :: g a -> AtomType -> Atom
5459 toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType
5560 toAtomsG :: g a -> [Atom]
56−
57−-- Right | Left
58− {-
59−instance (AtomableG (a p), AtomableG (b p)) => AtomableG ((a :+: b) p) where
60− --type AtomTG (a :+: b) = (AtomTG a, AtomTG b)
61− toAtomG v = undefined
62− toAtomTypeG v = undefined
63−
64−-- Test Int Int
65−instance (Atomable (a p), Atomable (b p)) => AtomableG ((a :*: b) p) where
66− toAtomG = undefined
67− toAtomTypeG (x :*: y) = undefined
68−-}
61+ toDatabaseContextExprG :: g a -> AtomType -> DatabaseContextExpr
62+ getConstructorsG :: g a -> [DataConstructorDef]
63+ getConstructorArgsG :: g a -> [DataConstructorDefArg]
6964
7065--data type metadata
7166instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where
7267 toAtomG (M1 v) t = toAtomG v t
73− toAtomsG = undefined
68+ toAtomsG = missingError
7469 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?
7570 where
76− typeName = datatypeName (undefined :: M1 D c a x)
71+ typeName = datatypeName (missingError :: M1 D c a x)
72+ toDatabaseContextExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors
73+ where
74+ tcDef = ADTypeConstructorDef tcName []
75+ dataConstructors = getConstructorsG v
76+ toDatabaseContextExprG _ _ = NoOperation
77+ getConstructorsG = missingError
78+ getConstructorArgsG = missingError
7779
78−
80+--constructor metadata
7981instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
8082 --constructor name needed for Atom but not for atomType
8183 toAtomG (M1 v) t = ConstructedAtom (T.pack constructorName) t atoms
8284 where
8385 atoms = toAtomsG v
84− constructorName = conName (undefined :: M1 C c a x)
85− toAtomsG = undefined
86− toAtomTypeG = undefined
86+ constructorName = conName (missingError :: M1 C c a x)
87+ toAtomsG = missingError
88+ toAtomTypeG = missingError
89+ toDatabaseContextExprG = missingError
90+ getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs]
91+ where
92+ dName = conName (missingError :: M1 C c a x)
93+ dArgs = getConstructorArgsG v
94+ getConstructorArgsG = missingError
8795
96+--field metadata
8897instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where
89− toAtomG = undefined
98+ toAtomG = missingError
9099 toAtomsG (M1 v) = toAtomsG v
91100 toAtomTypeG (M1 v) = toAtomTypeG v
101+ toDatabaseContextExprG _ _ = missingError
102+ getConstructorsG = error "hm"
103+ getConstructorArgsG (M1 v) = getConstructorArgsG v
92104
105+-- field data metadata
93106instance (Atomable a) => AtomableG (K1 c a) where
94107 toAtomG (K1 v) _ = toAtom v
95108 toAtomsG (K1 v) = [toAtom v]
96− toAtomTypeG (K1 v) = toAtomType (undefined :: a)
97−
109+ toAtomTypeG _ = toAtomType (missingError :: a)
110+ toDatabaseContextExprG _ _ = missingError
111+ getConstructorsG = missingError
112+ getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons]
113+ where
114+ tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType
115+ primitiveAType = toAtomType v
116+ primitiveATypeName = case foldr (\((PrimitiveTypeConstructorDef name typ), _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping of
117+ Just x -> x
118+ Nothing -> error ("primitive type missing: " ++ show primitiveAType)
119+
120+-- product types
98121instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
99− toAtomG = undefined
100− toAtomTypeG = undefined
122+ toAtomG = missingError
123+ toAtomTypeG = missingError
101124 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y
125+ toDatabaseContextExprG _ _ = missingError
126+ getConstructorsG = missingError
127+ getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y
128+
129+-- sum types
130+instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
131+ toAtomG (L1 x) = toAtomG x
132+ toAtomG (R1 x) = toAtomG x
133+ toAtomTypeG = missingError
134+ toAtomsG (L1 x) = toAtomsG x
135+ toAtomsG (R1 x) = toAtomsG x
136+ toDatabaseContextExprG _ _ = missingError
137+ getConstructorsG (L1 x) = getConstructorsG x
138+ getConstructorsG (R1 x) = getConstructorsG x
139+ getConstructorArgsG = missingError
140+
141+--this represents the unimplemented generics traversals which should never be called
142+missingError :: a
143+missingError = error "missing generics traversal"
144+
145+{-
146+appendExpr :: DatabaseContextExpr -> DatabaseContextExpr -> DatabaseContextExpr
147+appendExpr expr (MultipleExpr l) = MultipleExpr l ++ [expr]
148+appendExpr exprA exprB = MultipleExpr [exprA, exprB]
149+-}
150+