043c90e · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP compilation checkpoint

fromAtom/toAtom functioning tests functioning

commit043c90e6eb37ad55536a88861ec5c77319523cdf authorAgentM <agentm@themactionfaction.com> dateFri 31 Mar 2017, 15:17 (10 years ago) parentf6d874b

3 files changed+96−12

compare with master

unifiedsplit

src/lib/ProjectM36/ConstructedAtom.hs+15−11 src/lib/ProjectM36/Key.hs−1 test/Relation/ConstructedAtom.hs+81

src/lib/ProjectM36/ConstructedAtom.hs+15−11

@@ -5,14 +5,16 @@ module ProjectM36.ConstructedAtom where

55import ProjectM36.Base

66import ProjectM36.DataTypes.Primitive

77import GHC.Generics

8−import qualified Data.Text as T

98import qualified Data.Map as M

9+import qualified Data.Text as T

1010import Control.DeepSeq (NFData)

1111import Data.Binary

12+import Control.Applicative

1213

1314--also add haskell scripting atomable support

1415--rename this module to Atomable along with test

1516

17+{-

1618data Test1T = Test1C Int

1719 deriving (Generic, Show, Eq, Binary, NFData, Atomable)

1820

@@ -21,7 +23,7 @@ data Test2T = Test2C Int Int

2123

2224data Test3T = Test3Ca | Test3Cb

2325 deriving (Generic, Show, Eq, Binary, NFData, Atomable)

24−

26+-}

2527class (Eq a, NFData a, Binary a, Show a) => Atomable a where

2628 toAtom :: a -> Atom

2729 default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom

@@ -32,7 +34,9 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where

3234 fromAtom v@(ConstructedAtom _ _ args) = case fromAtomG v args of

3335 Nothing -> error "no fromAtomG traversal found"

3436 Just x -> to x

35− fromAtom v = to (fromAtomG v [])

37+ fromAtom v = case fromAtomG v [] of

38+ Nothing -> error "no fromAtomG for Atom found"

39+ Just x -> to x

3640

3741 toAtomType :: a -> AtomType

3842 default toAtomType :: (Generic a, AtomableG (Rep a)) => a -> AtomType

@@ -71,7 +75,7 @@ class AtomableG g where

7175--data type metadata

7276instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where

7377 toAtomG (M1 v) t = toAtomG v t

74− fromAtomG atom args = M1 (fromAtomG atom args)

78+ fromAtomG atom args = M1 <$> fromAtomG atom args

7579 toAtomsG = undefined

7680 toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?

7781 where

@@ -92,9 +96,9 @@ instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where

9296 atoms = toAtomsG v

9397 constructorName = conName (undefined :: M1 C c a x)

9498 fromAtomG atom@(ConstructedAtom dConsName _ _) args = if dName == dConsName then

95− M1 (fromAtomG atom args)

99+ M1 <$> fromAtomG atom args

96100 else

97− error "constructor name mismatch"

101+ Nothing

98102 where

99103 dName = T.pack (conName (undefined :: M1 C c a x))

100104 fromAtomG _ _ = error "unsupported generic traversal"

@@ -110,7 +114,7 @@ instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where

110114--field metadata

111115instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where

112116 toAtomG = undefined

113− fromAtomG atom args = M1 (fromAtomG atom args)

117+ fromAtomG atom args = M1 <$> fromAtomG atom args

114118 toAtomsG (M1 v) = toAtomsG v

115119 toAtomTypeG (M1 v) = toAtomTypeG v

116120 toDatabaseContextExprG _ _ = undefined

@@ -120,7 +124,7 @@ instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where

120124-- field data metadata

121125instance (Atomable a) => AtomableG (K1 c a) where

122126 toAtomG (K1 v) _ = toAtom v

123− fromAtomG _ args = K1 (fromAtom (headatom args))

127+ fromAtomG _ args = K1 <$> Just (fromAtom (headatom args))

124128 where headatom (x:_) = x

125129 headatom [] = error "no more atoms for constructor!"

126130 toAtomsG (K1 v) = [toAtom v]

@@ -137,7 +141,7 @@ instance (Atomable a) => AtomableG (K1 c a) where

137141

138142instance AtomableG U1 where

139143 toAtomG = undefined

140− fromAtomG _ = pure U1

144+ fromAtomG _ _ = pure U1

141145 toAtomsG _ = []

142146 toAtomTypeG = undefined

143147 toDatabaseContextExprG = undefined

@@ -147,7 +151,7 @@ instance AtomableG U1 where

147151-- product types

148152instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where

149153 toAtomG = undefined

150− fromAtomG atom args = (:*:) (fromAtomG atom [headatom args]) (fromAtomG atom (tailatoms args))

154+ fromAtomG atom args = (:*:) <$> (fromAtomG atom [headatom args]) <*> (fromAtomG atom (tailatoms args))

151155 where headatom (x:_) = x

152156 headatom [] = error "no more atoms in head for product!"

153157 tailatoms (_:xs) = xs

@@ -162,7 +166,7 @@ instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where

162166instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where

163167 toAtomG (L1 x) = toAtomG x

164168 toAtomG (R1 x) = toAtomG x

165− fromAtomG atom args = L1 (fromAtomG atom args) -- I can take both branches, match on the dconsname and return through the Either monad

169+ fromAtomG atom args = (L1 <$> fromAtomG atom args) <|> (R1 <$> fromAtomG atom args)

166170 toAtomTypeG = undefined

167171 toAtomsG (L1 x) = toAtomsG x

168172 toAtomsG (R1 x) = toAtomsG x

src/lib/ProjectM36/Key.hs−1

@@ -3,7 +3,6 @@ import ProjectM36.Base

33import ProjectM36.Relation

44import qualified Data.Set as S

55import Data.Monoid

6−import qualified Data.Text as T

87{-

98keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth

test/Relation/ConstructedAtom.hsnew file+81

@@ -0,0 +1,81 @@

1+--Test Atomable typeclass which allows users to use existing Haskell datatypes to marshal them to and from the database as ConstructedAtoms.

2+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings #-}

3+import Test.HUnit

4+import ProjectM36.Client

5+import Data.Binary

6+import Control.DeepSeq

7+import System.Exit

8+import TutorialD.Interpreter.TestBase

9+import GHC.Generics

10+import ProjectM36.Base

11+import Data.Text

12+

13+data Test1T = Test1C Int

14+ deriving (Generic, Show, Eq, Binary, NFData, Atomable)

15+

16+data Test2T x = Test2C x

17+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)

18+

19+data Test3T = Test3C Int Int

20+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)

21+

22+data Test4T = Test4Ca Int |

23+ Test4Cb Int

24+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)

25+

26+data Test5T = Test5C {

27+ con1 :: Int,

28+ con2 :: Int

29+ } deriving (Show, Generic, Eq, Binary, NFData, Atomable)

30+

31+main :: IO ()

32+main = do

33+ tcounts <- runTestTT testList

34+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

35+

36+testList :: Test

37+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5]

38+

39+--test marshaling of Generics-derived Atom to database ADT

40+testHaskell2DB :: Test

41+testHaskell2DB = TestCase $ do

42+ --validate generated database context expression

43+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

44+ let test1TExpr = toDatabaseContextExpr (undefined :: Test1T)

45+ expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" IntAtomType)]]

46+ assertEqual "simple ADT1" expectedTest1TExpr test1TExpr

47+ checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr

48+

49+testADT1 :: Test

50+testADT1 = TestCase $ do

51+ let example = Test1C 3

52+ assertEqual "one arg constructor" example (fromAtom (toAtom example))

53+

54+testADT2 :: Test

55+testADT2 = TestCase $ do

56+ let sampletext = "text" :: Text

57+ example = Test2C sampletext

58+ assertEqual "polymorphic type constructor" example (fromAtom (toAtom example))

59+

60+testADT3 :: Test

61+testADT3 = TestCase $ do

62+ let example = Test3C 3 4

63+ assertEqual "product type" example (fromAtom (toAtom example))

64+

65+testADT4 :: Test

66+testADT4 = TestCase $ do

67+ let example = Test4Ca 3

68+ example2 = Test4Cb 4

69+ assertEqual "sum type + one constructor arg 1" example (fromAtom (toAtom example))

70+ assertEqual "sum type + one constructor arg 2" example2 (fromAtom (toAtom example2))

71+

72+testADT5 :: Test

73+testADT5 = TestCase $ do

74+ let example = Test5C {con1=3, con2=4}

75+ assertEqual "record-based ADT" example (fromAtom (toAtom example))

76+

77+checkExecuteDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO ()

78+checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextExpr sessionId dbconn expr >>= maybe (pure ()) (\err -> assertFailure (show err))

79+

80+

81+