@@ -10,39 +10,28 @@ import qualified Data.Map as M
1010import Control.DeepSeq (NFData)
1111import Data.Binary
1212
13−data TestT = TestC Int
14− deriving (Generic, Show, Eq, Binary, NFData)
15−
16−data Test2T x = Test2C x
17− deriving (Show, Generic, Eq, Binary, NFData)
18−
19−data Test3T = Test3C Int Int
20− deriving (Show, Generic, Eq, Binary, NFData)
21−
22−data Test4T = Test4Ca Int |
23− Test4Cb Int
24− deriving (Show, Generic, Eq, Binary, NFData)
25−
26−data Test5T = Test5Ca | Test5Cb
27− deriving (Show, Generic, Eq, Binary, NFData)
28−
29−data TyTest a = TyTest a
13+--also add haskell scripting atomable support
14+--rename this module to Atomable along with test
3015
31−instance Atomable TestT
32−instance Atomable a => Atomable (Test2T a)
33−instance Atomable Test3T
34−instance Atomable Test4T
35−instance Atomable Test5T
16+data Test1T = Test1C Int
17+ deriving (Generic, Show, Eq, Binary, NFData, Atomable)
18+
19+data Test2T = Test2C Int Int
20+ deriving (Generic, Show, Eq, Binary, NFData, Atomable)
3621
3722class (Eq a, NFData a, Binary a, Show a) => Atomable a where
3823 toAtom :: a -> Atom
3924 default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom
4025 toAtom v = toAtomG (from v) (toAtomTypeG (from v))
4126
27+ fromAtom :: Atom -> a
28+ default fromAtom :: (Generic a, AtomableG (Rep a)) => Atom -> a
29+ fromAtom = to `fmap` fromAtomG
30+
4231 toAtomType :: a -> AtomType
4332 default toAtomType :: (Generic a, AtomableG (Rep a)) => a -> AtomType
4433 toAtomType v = toAtomTypeG (from v)
45−
34+
4635 --creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database
4736 toDatabaseContextExpr :: a -> DatabaseContextExpr
4837 default toDatabaseContextExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr
@@ -50,11 +39,15 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where
5039
5140instance Atomable Int where
5241 toAtom i = IntAtom i
42+ fromAtom (IntAtom i) = i
43+ fromAtom e = error ("improper fromAtom" ++ show e)
5344 toAtomType _ = IntAtomType
5445 toDatabaseContextExpr _ = NoOperation
5546
5647instance Atomable T.Text where
57− toAtom i = TextAtom i
48+ toAtom t = TextAtom t
49+ fromAtom (TextAtom t) = t
50+ fromAtom _ = error "improper fromAtom"
5851 toAtomType _ = TextAtomType
5952 toDatabaseContextExpr _ = NoOperation
6053
@@ -62,6 +55,7 @@ instance Atomable T.Text where
6255class AtomableG g where
6356 --type AtomTG g
6457 toAtomG :: g a -> AtomType -> Atom
58+ fromAtomG :: Atom -> g a
6559 toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType
6660 toAtomsG :: g a -> [Atom]
6761 toDatabaseContextExprG :: g a -> AtomType -> DatabaseContextExpr
@@ -71,6 +65,7 @@ class AtomableG g where
7165--data type metadata
7266instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where
7367 toAtomG (M1 v) t = toAtomG v t
68+ fromAtomG = M1 <$> fromAtomG
7469 toAtomsG = undefined
7570 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?
7671 where
@@ -90,6 +85,7 @@ instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
9085 where
9186 atoms = toAtomsG v
9287 constructorName = conName (undefined :: M1 C c a x)
88+ fromAtomG = M1 <$> fromAtomG
9389 toAtomsG = undefined
9490 toAtomTypeG = undefined
9591 toDatabaseContextExprG = undefined
@@ -102,6 +98,7 @@ instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
10298--field metadata
10399instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where
104100 toAtomG = undefined
101+ fromAtomG = M1 <$> fromAtomG
105102 toAtomsG (M1 v) = toAtomsG v
106103 toAtomTypeG (M1 v) = toAtomTypeG v
107104 toDatabaseContextExprG _ _ = undefined
@@ -111,6 +108,7 @@ instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where
111108-- field data metadata
112109instance (Atomable a) => AtomableG (K1 c a) where
113110 toAtomG (K1 v) _ = toAtom v
111+ fromAtomG = K1 <$> fromAtom
114112 toAtomsG (K1 v) = [toAtom v]
115113 toAtomTypeG _ = toAtomType (undefined :: a)
116114 toDatabaseContextExprG _ _ = undefined
@@ -125,6 +123,7 @@ instance (Atomable a) => AtomableG (K1 c a) where
125123
126124instance AtomableG U1 where
127125 toAtomG = undefined
126+ fromAtomG = pure U1
128127 toAtomsG _ = []
129128 toAtomTypeG = undefined
130129 toDatabaseContextExprG = undefined
@@ -134,6 +133,7 @@ instance AtomableG U1 where
134133-- product types
135134instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
136135 toAtomG = undefined
136+ fromAtomG = (:*:) <$> fromAtomG <*> fromAtomG
137137 toAtomTypeG = undefined
138138 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y
139139 toDatabaseContextExprG _ _ = undefined
@@ -144,6 +144,7 @@ instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
144144instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
145145 toAtomG (L1 x) = toAtomG x
146146 toAtomG (R1 x) = toAtomG x
147+ fromAtomG = undefined
147148 toAtomTypeG = undefined
148149 toAtomsG (L1 x) = toAtomsG x
149150 toAtomsG (R1 x) = toAtomsG x
@@ -152,12 +153,8 @@ instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
152153 getConstructorArgsG = undefined
153154
154155--this represents the unimplemented generics traversals which should never be called
156+{-
155157missingError :: a
156158missingError = error "missing generics traversal"
157−
158−{-
159−appendExpr :: DatabaseContextExpr -> DatabaseContextExpr -> DatabaseContextExpr
160−appendExpr expr (MultipleExpr l) = MultipleExpr l ++ [expr]
161−appendExpr exprA exprB = MultipleExpr [exprA, exprB]
162159-}
163160