git.iko.soy/project-m36
on master help sign in
Fix AtomableG (K1 c a) instance
a6efc33AgentM
src/lib/ProjectM36/Atomable.hs+20−6
compare with master
unifiedsplit
@@ -4,7 +4,6 @@ module ProjectM36.Atomable where
4--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data
4--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data
5--instances to marshal Haskell ADTs to ConstructedAtoms and back
5--instances to marshal Haskell ADTs to ConstructedAtoms and back
6import ProjectM36.Base
6import ProjectM36.Base
7−import ProjectM36.DataTypes.Primitive
8import ProjectM36.DataTypes.List
7import ProjectM36.DataTypes.List
9import ProjectM36.DataTypes.NonEmptyList
8import ProjectM36.DataTypes.NonEmptyList
10import ProjectM36.DataTypes.Maybe
9import ProjectM36.DataTypes.Maybe
@@ -12,13 +11,13 @@ import ProjectM36.DataTypes.Either
12import GHC.Generics
11import GHC.Generics
13import qualified Data.Map as M
12import qualified Data.Map as M
14import qualified Data.Text as T
13import qualified Data.Text as T
14+import qualified Data.Vector as V
15import Control.DeepSeq (NFData)
15import Control.DeepSeq (NFData)
16import Data.Binary
16import Data.Binary
17import Control.Applicative
17import Control.Applicative
18import Data.Time.Calendar
18import Data.Time.Calendar
19import Data.ByteString (ByteString)
19import Data.ByteString (ByteString)
20import Data.Time.Clock
20import Data.Time.Clock
21−import Data.Maybe
22import Data.Proxy
21import Data.Proxy
23import qualified Data.List.NonEmpty as NE
22import qualified Data.List.NonEmpty as NE
24
23
@@ -242,10 +241,25 @@ instance (Atomable a) => AtomableG (K1 c a) where
242 getConstructorsG = undefined
241 getConstructorsG = undefined
243 getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]
242 getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]
244 where
243 where
245− tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType
246− primitiveAType = toAtomType (Proxy :: Proxy a)
244+ tCons = typeToTypeConstructor $ toAtomType (Proxy :: Proxy a)
247− primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) acc -> if typ == primitiveAType then Just name else acc) Nothing primitiveTypeConstructorMapping)
245+
248−
246+typeToTypeConstructor :: AtomType -> TypeConstructor
247+typeToTypeConstructor x@(IntAtomType) = PrimitiveTypeConstructor "Int" x
248+typeToTypeConstructor x@(IntegerAtomType) = PrimitiveTypeConstructor "Integer" x
249+typeToTypeConstructor x@(DoubleAtomType) = PrimitiveTypeConstructor "Double" x
250+typeToTypeConstructor x@(TextAtomType) = PrimitiveTypeConstructor "Text" x
251+typeToTypeConstructor x@(DayAtomType) = PrimitiveTypeConstructor "Day" x
252+typeToTypeConstructor x@(DateTimeAtomType) = PrimitiveTypeConstructor "DateTime" x
253+typeToTypeConstructor x@(ByteStringAtomType) = PrimitiveTypeConstructor "ByteString" x
254+typeToTypeConstructor x@(BoolAtomType) = PrimitiveTypeConstructor "Bool" x
255+typeToTypeConstructor (RelationAtomType attrs)
256+ = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList attrs
257+ where
258+ attrToAttrExpr (Attribute n t) = AttributeAndTypeNameExpr n (typeToTypeConstructor t) ()
259+typeToTypeConstructor (ConstructedAtomType tcName tvMap)
260+ = ADTypeConstructor tcName $ map typeToTypeConstructor (M.elems tvMap)
261+typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName
262+
249instance AtomableG U1 where
263instance AtomableG U1 where
250 toAtomG = undefined
264 toAtomG = undefined
251 fromAtomG _ _ = pure U1
265 fromAtomG _ _ = pure U1
test/Relation/Atomable.hs+9−1
@@ -44,6 +44,9 @@ data Test6T = Test6C (Maybe Integer)
44
44
45data Test7T = Test7C (Either Integer Integer)
45data Test7T = Test7C (Either Integer Integer)
46 deriving (Show, Generic, Eq, Binary, NFData, Atomable)
46 deriving (Show, Generic, Eq, Binary, NFData, Atomable)
47+
48+data Test8T = Test8C Test1T
49+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)
47
50
48main :: IO ()
51main :: IO ()
49main = do
52main = do
@@ -51,7 +54,7 @@ main = do
51 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
54 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
52
55
53testList :: Test
56testList :: Test
54−testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either]
57+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues]
55
58
56
59
57-- test some basic data types like int, day, etc.
60-- test some basic data types like int, day, etc.
@@ -141,3 +144,8 @@ testNonEmptyInstance :: Test
141testNonEmptyInstance = TestCase $ do
144testNonEmptyInstance = TestCase $ do
142 let example = TestNonEmptyC [3,4,5]
145 let example = TestNonEmptyC [3,4,5]
143 assertEqual "NonEmpty instance" example (fromAtom (toAtom example))
146 assertEqual "NonEmpty instance" example (fromAtom (toAtom example))
147+
148+testNonPrimitiveValues :: Test
149+testNonPrimitiveValues = TestCase $ do
150+ let example = Test8C (Test1C 3)
151+ assertEqual "non-primitive values" example (fromAtom (toAtom example))