git.iko.soy/project-m36
on master help sign in
Fix AtomableG (K1 c a) instance

Derivation failed for multiple levels of indirection, e.g. data Typ1 = Typ1 Int data Typ2 = Typ2 Int data Typ3 = Typ31 Typ1 | Typ32 Typ2 here toAddTypeExpr (Proxy :: Proxy Typ3) would always fail with a confusing error message regarding primitive types. This was happening because it was assumed that data construction arguments are primitive, which is not always the case. # Conflicts: # src/lib/ProjectM36/Atomable.hs

commita6efc3377805943fb6e3cdd65415dca871b2b3b5 authorAgentM <agentm@themactionfaction.com> dateWed 12 Dec 2018, 23:34 (8 years ago) parentefc8ec0
2 files changed+29−7
compare with master
unifiedsplit
src/lib/ProjectM36/Atomable.hs+20−6 test/Relation/Atomable.hs+9−1
src/lib/ProjectM36/Atomable.hs+20−6
@@ -4,7 +4,6 @@ module ProjectM36.Atomable where
44--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data
55--instances to marshal Haskell ADTs to ConstructedAtoms and back
66import ProjectM36.Base
7−import ProjectM36.DataTypes.Primitive
87import ProjectM36.DataTypes.List
98import ProjectM36.DataTypes.NonEmptyList
109import ProjectM36.DataTypes.Maybe
@@ -12,13 +11,13 @@ import ProjectM36.DataTypes.Either
1211import GHC.Generics
1312import qualified Data.Map as M
1413import qualified Data.Text as T
14+import qualified Data.Vector as V
1515import Control.DeepSeq (NFData)
1616import Data.Binary
1717import Control.Applicative
1818import Data.Time.Calendar
1919import Data.ByteString (ByteString)
2020import Data.Time.Clock
21−import Data.Maybe
2221import Data.Proxy
2322import qualified Data.List.NonEmpty as NE
2423
@@ -242,10 +241,25 @@ instance (Atomable a) => AtomableG (K1 c a) where
242241 getConstructorsG = undefined
243242 getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]
244243 where
245− tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType
246− primitiveAType = 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)
248−
244+ tCons = typeToTypeConstructor $ toAtomType (Proxy :: Proxy a)
245+
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+
249263instance AtomableG U1 where
250264 toAtomG = undefined
251265 fromAtomG _ _ = pure U1
test/Relation/Atomable.hs+9−1
@@ -44,6 +44,9 @@ data Test6T = Test6C (Maybe Integer)
4444
4545data Test7T = Test7C (Either Integer Integer)
4646 deriving (Show, Generic, Eq, Binary, NFData, Atomable)
47+
48+data Test8T = Test8C Test1T
49+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)
4750
4851main :: IO ()
4952main = do
@@ -51,7 +54,7 @@ main = do
5154 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
5255
5356testList :: 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]
5558
5659
5760-- test some basic data types like int, day, etc.
@@ -141,3 +144,8 @@ testNonEmptyInstance :: Test
141144testNonEmptyInstance = TestCase $ do
142145 let example = TestNonEmptyC [3,4,5]
143146 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))