git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/src/lib/ProjectM36/Atomable.hs
274 lines 11 kB history raw
1{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts #-}
2module ProjectM36.Atomable where
3--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data
4--instances to marshal Haskell ADTs to ConstructedAtoms and back
5import ProjectM36.Base
6import ProjectM36.DataTypes.Primitive
7import ProjectM36.DataTypes.List
8import ProjectM36.DataTypes.Maybe
9import ProjectM36.DataTypes.Either
10import GHC.Generics
11import qualified Data.Map as M
12import qualified Data.Text as T
13import Control.DeepSeq (NFData)
14import Data.Binary
15import Control.Applicative
16import Data.Time.Calendar
17import Data.ByteString (ByteString)
18import Data.Time.Clock
19import Data.Maybe
20import Data.Proxy
22--also add haskell scripting atomable support
23--rename this module to Atomable along with test
25{-
26data Test1T = Test1C Int
27 deriving (Generic, Show, Eq, Binary, NFData, Atomable)
29data Test2T = Test2C Int Int
30 deriving (Generic, Show, Eq, Binary, NFData, Atomable)
32data Test3T = Test3Ca | Test3Cb
33 deriving (Generic, Show, Eq, Binary, NFData, Atomable)
34-}
35-- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values.
36class (Eq a, NFData a, Binary a, Show a) => Atomable a where
37 toAtom :: a -> Atom
38 default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom
39 toAtom v = toAtomG (from v) (toAtomTypeG (from v))
41 fromAtom :: Atom -> a
42 default fromAtom :: (Generic a, AtomableG (Rep a)) => Atom -> a
43 fromAtom v@(ConstructedAtom _ _ args) = case fromAtomG v args of
44 Nothing -> error "no fromAtomG traversal found"
45 Just x -> to x
46 fromAtom v = case fromAtomG v [] of
47 Nothing -> error "no fromAtomG for Atom found"
48 Just x -> to x
50 toAtomType :: proxy a -> AtomType
51 default toAtomType :: (Generic a, AtomableG (Rep a)) => proxy a -> AtomType
52 toAtomType _ = toAtomTypeG (from (undefined :: a))
54 -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.
55 toAddTypeExpr :: Proxy a -> DatabaseContextExpr
56 default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr
57 toAddTypeExpr _ = toAddTypeExprG (from (undefined :: a)) (toAtomType (Proxy :: Proxy a))
59instance Atomable Integer where
60 toAtom = IntegerAtom
61 fromAtom (IntegerAtom i) = i
62 fromAtom e = error ("improper fromAtom" ++ show e)
63 toAtomType _ = IntegerAtomType
64 toAddTypeExpr _ = NoOperation
66instance Atomable Int where
67 toAtom = IntAtom
68 fromAtom (IntAtom i) = i
69 fromAtom e = error ("improper fromAtom" ++ show e)
70 toAtomType _ = IntAtomType
71 toAddTypeExpr _ = NoOperation
73instance Atomable Double where
74 toAtom = DoubleAtom
75 fromAtom (DoubleAtom d) = d
76 fromAtom _ = error "improper fromAtom"
77 toAtomType _ = DoubleAtomType
78 toAddTypeExpr _ = NoOperation
80instance Atomable T.Text where
81 toAtom = TextAtom
82 fromAtom (TextAtom t) = t
83 fromAtom _ = error "improper fromAtom"
84 toAtomType _ = TextAtomType
85 toAddTypeExpr _ = NoOperation
87instance Atomable Day where
88 toAtom = DayAtom
89 fromAtom (DayAtom d) = d
90 fromAtom _ = error "improper fromAtom"
91 toAtomType _ = DayAtomType
92 toAddTypeExpr _ = NoOperation
94instance Atomable UTCTime where
95 toAtom = DateTimeAtom
96 fromAtom (DateTimeAtom t) = t
97 fromAtom _ = error "improper fromAtom"
98 toAtomType _ = DateTimeAtomType
99 toAddTypeExpr _ = NoOperation
101instance Atomable ByteString where
102 toAtom = ByteStringAtom
103 fromAtom (ByteStringAtom b) = b
104 fromAtom _ = error "improper fromAtom"
105 toAtomType _ = ByteStringAtomType
106 toAddTypeExpr _ = NoOperation
108instance Atomable Bool where
109 toAtom = BoolAtom
110 fromAtom (BoolAtom b) = b
111 fromAtom _ = error "improper fromAtom"
112 toAtomType _ = BoolAtomType
113 toAddTypeExpr _ = NoOperation
115{-
116instance Atomable Relation where
117 toAtom = RelationAtom
118 fromAtom (RelationAtom r) = r
119 fromAtom _ = error "improper fromAtom"
120 --warning: cannot be used with undefined "Relation"
121 toAtomType rel = RelationAtomType (attributes rel)
122 toAddTypeExpr _ = NoOperation
123-}
125instance Atomable a => Atomable (Maybe a) where
126 toAtom (Just v) = ConstructedAtom "Just" (maybeAtomType (toAtomType (Proxy :: Proxy a))) [toAtom v]
127 toAtom Nothing = ConstructedAtom "Nothing" (maybeAtomType (toAtomType (Proxy :: Proxy a))) []
129 fromAtom (ConstructedAtom "Just" _ [val]) = Just (fromAtom val)
130 fromAtom (ConstructedAtom "Nothing" _ []) = Nothing
131 fromAtom _ = error "improper fromAtom (Maybe a)"
133 toAtomType _ = ConstructedAtomType "Maybe" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))
134 toAddTypeExpr _ = NoOperation
136instance (Atomable a, Atomable b) => Atomable (Either a b) where
137 toAtom (Left l) = ConstructedAtom "Left" (eitherAtomType (toAtomType (Proxy :: Proxy a))
138 (toAtomType (Proxy :: Proxy b))) [toAtom l]
139 toAtom (Right r) = ConstructedAtom "Right" (eitherAtomType (toAtomType (Proxy :: Proxy a))
140 (toAtomType (Proxy :: Proxy b))) [toAtom r]
142 fromAtom (ConstructedAtom "Left" _ [val]) = Left (fromAtom val)
143 fromAtom (ConstructedAtom "Right" _ [val]) = Right (fromAtom val)
144 fromAtom _ = error "improper fromAtom (Either a b)"
146--convert to ADT list
147instance Atomable a => Atomable [a] where
148 toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (Proxy :: Proxy a))) []
149 toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs))
151 fromAtom (ConstructedAtom "Empty" _ _) = []
152 fromAtom (ConstructedAtom "Cons" _ (x:xs)) = fromAtom x:map fromAtom xs
153 fromAtom _ = error "improper fromAtom [a]"
155 toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))
156 toAddTypeExpr _ = NoOperation
158-- Generics
159class AtomableG g where
160 --type AtomTG g
161 toAtomG :: g a -> AtomType -> Atom
162 fromAtomG :: Atom -> [Atom] -> Maybe (g a)
163 toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType
164 toAtomsG :: g a -> [Atom]
165 toAddTypeExprG :: g a -> AtomType -> DatabaseContextExpr
166 getConstructorsG :: g a -> [DataConstructorDef]
167 getConstructorArgsG :: g a -> [DataConstructorDefArg]
169--data type metadata
170instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where
171 toAtomG (M1 v) = toAtomG v
172 fromAtomG atom args = M1 <$> fromAtomG atom args
173 toAtomsG = undefined
174 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?
175 where
176 typeName = datatypeName (undefined :: M1 D c a x)
177 toAddTypeExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors
178 where
179 tcDef = ADTypeConstructorDef tcName []
180 dataConstructors = getConstructorsG v
181 toAddTypeExprG _ _ = NoOperation
182 getConstructorsG (M1 v) = getConstructorsG v
183 getConstructorArgsG = undefined
185--constructor metadata
186instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
187 --constructor name needed for Atom but not for atomType
188 toAtomG (M1 v) t = ConstructedAtom (T.pack constructorName) t atoms
189 where
190 atoms = toAtomsG v
191 constructorName = conName (undefined :: M1 C c a x)
192 fromAtomG atom@(ConstructedAtom dConsName _ _) args = if dName == dConsName then
193 M1 <$> fromAtomG atom args
194 else
195 Nothing
196 where
197 dName = T.pack (conName (undefined :: M1 C c a x))
198 fromAtomG _ _ = error "unsupported generic traversal"
199 toAtomsG = undefined
200 toAtomTypeG = undefined
201 toAddTypeExprG = undefined
202 getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs]
203 where
204 dName = conName (undefined :: M1 C c a x)
205 dArgs = getConstructorArgsG v
206 getConstructorArgsG = undefined
208--field metadata
209instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where
210 toAtomG = undefined
211 fromAtomG atom args = M1 <$> fromAtomG atom args
212 toAtomsG (M1 v) = toAtomsG v
213 toAtomTypeG (M1 v) = toAtomTypeG v
214 toAddTypeExprG _ _ = undefined
215 getConstructorsG = undefined
216 getConstructorArgsG (M1 v) = getConstructorArgsG v
218-- field data metadata
219instance (Atomable a) => AtomableG (K1 c a) where
220 toAtomG (K1 v) _ = toAtom v
221 fromAtomG _ args = K1 <$> Just (fromAtom (headatom args))
222 where headatom (x:_) = x
223 headatom [] = error "no more atoms for constructor!"
224 toAtomsG (K1 v) = [toAtom v]
225 toAtomTypeG _ = toAtomType (Proxy :: Proxy a)
226 toAddTypeExprG _ _ = undefined
227 getConstructorsG = undefined
228 getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]
229 where
230 tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType
231 primitiveAType = toAtomType (Proxy :: Proxy a)
232 primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping)
234instance AtomableG U1 where
235 toAtomG = undefined
236 fromAtomG _ _ = pure U1
237 toAtomsG _ = []
238 toAtomTypeG = undefined
239 toAddTypeExprG = undefined
240 getConstructorsG = undefined
241 getConstructorArgsG _ = []
243-- product types
244instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
245 toAtomG = undefined
246 fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args)
247 where headatom (x:_) = x
248 headatom [] = error "no more atoms in head for product!"
249 tailatoms (_:xs) = xs
250 tailatoms [] = error "no more atoms in tail for product!"
251 toAtomTypeG = undefined
252 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y
253 toAddTypeExprG _ _ = undefined
254 getConstructorsG = undefined
255 getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y
257-- sum types
258instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
259 toAtomG (L1 x) = toAtomG x
260 toAtomG (R1 x) = toAtomG x
261 fromAtomG atom args = (L1 <$> fromAtomG atom args) <|> (R1 <$> fromAtomG atom args)
262 toAtomTypeG = undefined
263 toAtomsG (L1 x) = toAtomsG x
264 toAtomsG (R1 x) = toAtomsG x
265 toAddTypeExprG _ _ = undefined
266 getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x)
267 getConstructorArgsG = undefined
269--this represents the unimplemented generics traversals which should never be called
270{-
271missingError :: a
272missingError = error "missing generics traversal"
273-}