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

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

043c90eAgentM10 years ago

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

compare with master

unifiedsplit

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

5import ProjectM36.Base

6import ProjectM36.DataTypes.Primitive

7import GHC.Generics

8−import qualified Data.Text as T

9import qualified Data.Map as M

8import qualified Data.Map as M

9+import qualified Data.Text as T

10import Control.DeepSeq (NFData)

11import Data.Binary

12+import Control.Applicative

13--also add haskell scripting atomable support

14--also add haskell scripting atomable support

14--rename this module to Atomable along with test

15--rename this module to Atomable along with test

17+{-

16data Test1T = Test1C Int

18data Test1T = Test1C Int

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

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

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

22data Test3T = Test3Ca | Test3Cb

24data Test3T = Test3Ca | Test3Cb

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

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

24−

26+-}

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

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

26 toAtom :: a -> Atom

28 toAtom :: a -> Atom

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

29 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

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

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

33 Nothing -> error "no fromAtomG traversal found"

35 Nothing -> error "no fromAtomG traversal found"

34 Just x -> to x

36 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

37 toAtomType :: a -> AtomType

41 toAtomType :: a -> AtomType

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

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

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

71--data type metadata

75--data type metadata

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

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

73 toAtomG (M1 v) t = toAtomG v t

77 toAtomG (M1 v) t = toAtomG v t

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

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

75 toAtomsG = undefined

79 toAtomsG = undefined

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

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

77 where

81 where

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

92 atoms = toAtomsG v

96 atoms = toAtomsG v

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

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

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

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

95− M1 (fromAtomG atom args)

99+ M1 <$> fromAtomG atom args

96 else

100 else

97− error "constructor name mismatch"

101+ Nothing

98 where

102 where

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

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

100 fromAtomG _ _ = error "unsupported generic traversal"

104 fromAtomG _ _ = error "unsupported generic traversal"

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

110--field metadata

114--field metadata

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

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

112 toAtomG = undefined

116 toAtomG = undefined

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

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

114 toAtomsG (M1 v) = toAtomsG v

118 toAtomsG (M1 v) = toAtomsG v

115 toAtomTypeG (M1 v) = toAtomTypeG v

119 toAtomTypeG (M1 v) = toAtomTypeG v

116 toDatabaseContextExprG _ _ = undefined

120 toDatabaseContextExprG _ _ = undefined

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

120-- field data metadata

124-- field data metadata

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

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

122 toAtomG (K1 v) _ = toAtom v

126 toAtomG (K1 v) _ = toAtom v

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

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

124 where headatom (x:_) = x

128 where headatom (x:_) = x

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

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

126 toAtomsG (K1 v) = [toAtom v]

130 toAtomsG (K1 v) = [toAtom v]

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

137

141

138instance AtomableG U1 where

142instance AtomableG U1 where

139 toAtomG = undefined

143 toAtomG = undefined

140− fromAtomG _ = pure U1

144+ fromAtomG _ _ = pure U1

141 toAtomsG _ = []

145 toAtomsG _ = []

142 toAtomTypeG = undefined

146 toAtomTypeG = undefined

143 toDatabaseContextExprG = undefined

147 toDatabaseContextExprG = undefined

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

147-- product types

151-- product types

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

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

149 toAtomG = undefined

153 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))

151 where headatom (x:_) = x

155 where headatom (x:_) = x

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

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

153 tailatoms (_:xs) = xs

157 tailatoms (_:xs) = xs

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

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

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

163 toAtomG (L1 x) = toAtomG x

167 toAtomG (L1 x) = toAtomG x

164 toAtomG (R1 x) = toAtomG x

168 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)

166 toAtomTypeG = undefined

170 toAtomTypeG = undefined

167 toAtomsG (L1 x) = toAtomsG x

171 toAtomsG (L1 x) = toAtomsG x

168 toAtomsG (R1 x) = toAtomsG x

172 toAtomsG (R1 x) = toAtomsG x

src/lib/ProjectM36/Key.hs−1

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

3import ProjectM36.Relation

4import qualified Data.Set as S

5import Data.Monoid

6−import qualified Data.Text as T

8{-

7{-

9keys 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

8keys 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+