07b9e1f · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge branch '144_proxy_tupleable'

commit07b9e1f8277f0af4f05a5e3f69e066e69efb53e1 authorAgentM <agentm@themactionfaction.com> dateFri 6 Oct 2017, 09:00 (9 years ago) parent6c8b678 d36fa64

9 files changed+74−57

compare with master

unifiedsplit

docs/new_datatypes.markdown+3−3 docs/tupleable.markdown+2−2 examples/blog.hs+4−3 examples/hair.hs+2−1 examples/out_of_the_tarpit.hs+11−10 src/lib/ProjectM36/Atomable.hs+22−20 src/lib/ProjectM36/Tupleable.hs+24−14 test/Relation/Atomable.hs+3−2 test/Relation/Tupleable.hs+3−2

docs/new_datatypes.markdown+3−3

@@ -103,9 +103,9 @@ The essential ```Atomable``` typeclass functions are:

103103| -------- | ------- |

104104| ```toAtom :: a -> Atom``` | convert a Haskell data type to a database atom |

105105| ```fromAtom :: Atom -> a``` | convert a database atom to a Haskell data type |

106−| ```toAtomType :: a -> AtomType``` | generate a database AtomType for a Haskell datatype |

107−| ```toAddTypeExpr :: a -> DatabaseContextExpr``` | generate a ```DatabaseContextExpr``` which can be executed against a database context in order to add the new type |

106+| ```toAtomType :: Proxy a -> AtomType``` | generate a database AtomType for a Haskell datatype |

107+| ```toAddTypeExpr :: Proxy a -> DatabaseContextExpr``` | generate a ```DatabaseContextExpr``` which can be executed against a database context in order to add the new type |

108108

109−In addition, basic Haskell data types like ```Int```, ```Double```, ```Text```, ```Day```, ```Bool```, ```UTCTime```, and l```ByteString``` already have Atomable instances ready-to-go. In addition, an ```Atomable``` instance is available for lists: ```Atomable a => [a]```, though one should be very careful not to use this in a common anti-pattern. Typically, it makes more sense to store one-to-many relationships as discrete relation variables; when storing them as lists, one gives up the various query capabilities and optimizations of the relational algebra.

109+In addition, basic Haskell data types like ```Int```, ```Double```, ```Text```, ```Day```, ```Bool```, ```UTCTime```, and l```ByteString``` already have `Atomable` instances ready-to-go. In addition, an ```Atomable``` instance is available for lists: ```Atomable a => [a]```, though one should be very careful not to use this in a common anti-pattern. Typically, it makes more sense to store one-to-many relationships as discrete relation variables; when storing them as lists, one gives up the various query capabilities and optimizations of the relational algebra.

110110

111111To be clear, these data types are not black boxes once stored in the database. These new types can be scanned and manipulated by Haskell scripts which can be created at runtime. For more information, read about [```AtomFunction```s](/docs/atomfunctions.markdown).

docs/tupleable.markdown+2−2

@@ -27,9 +27,9 @@ Now, ```Person``` values can be marshaled between the database and the client. T

2727

2828The ```Tupleable``` module includes the following functions:

2929

30− * ```toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr```

30+ * ```toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr```

3131 * creates an ```Insert``` expression which can be used to insert a set of ```Tupleable``` values into the relation variable named by the ```RelVarName```

32− * ```toAttributes :: a -> Attributes```

32+ * ```toAttributes :: proxy a -> Attributes```

3333 * generates ```Attributes``` from a ```Tupleable``` value- can be used with ```undefined```, so an actual value is not necessary

3434 * ```toTuple :: a -> RelationTuple```

3535 * converts a ```Tupleable``` value to a tuple for use in queries

examples/blog.hs+4−3

@@ -12,6 +12,7 @@ import qualified Data.Text as T

1212import Data.Time.Clock

1313import Data.Time.Calendar

1414import Control.DeepSeq

15+import Data.Proxy

1516

1617--define your data types

1718data Blog = Blog {

@@ -69,9 +70,9 @@ main = do

6970createSchema :: SessionId -> Connection -> IO ()

7071createSchema sessionId conn = do

7172 _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) [

72− toAddTypeExpr (undefined :: Category),

73− toDefineExpr (undefined :: Blog) "blog",

74− toDefineExpr (undefined :: Comment) "comment",

73+ toAddTypeExpr (Proxy :: Proxy Category),

74+ toDefineExpr (Proxy :: Proxy Blog) "blog",

75+ toDefineExpr (Proxy :: Proxy Comment) "comment",

7576 databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]) ]

7677 pure ()

7778

examples/hair.hs+2−1

@@ -7,6 +7,7 @@ import Data.Binary

77import Control.DeepSeq

88import qualified Data.Map as M

99import qualified Data.Text.IO as TIO

10+import Data.Proxy

1011

1112data Hair = Bald | Brown | Blond | OtherColor Text

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

@@ -26,7 +27,7 @@ main = do

2627 sessionId <- eCheck $ createSessionAtHead conn "master"

2728

2829 --create the data type in the database context

29− eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (undefined :: Hair))

30+ eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (Proxy :: Proxy Hair))

3031

3132 --create a relation with the new Hair AtomType

3233 let blond = NakedAtomExpr (toAtom Blond)

examples/out_of_the_tarpit.hs+11−10

@@ -11,6 +11,7 @@ import Data.Binary

1111import Control.DeepSeq

1212import qualified Data.Text as T

1313import Data.Time.Calendar

14+import Data.Proxy

1415

1516--create various database value (atom) types

1617type Price = Double

@@ -142,17 +143,17 @@ createSchema sessionId conn = do

142143 ]

143144 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys

144145 --define the relvars

145− rvExprs = [toDefineExpr (undefined :: Property) "property",

146− toDefineExpr (undefined :: Offer) "offer",

147− toDefineExpr (undefined :: Decision) "decision",

148− toDefineExpr (undefined :: Room) "room",

149− toDefineExpr (undefined :: Floor) "floor",

150− toDefineExpr (undefined :: Commission) "commission"]

146+ rvExprs = [toDefineExpr (Proxy :: Proxy Property) "property",

147+ toDefineExpr (Proxy :: Proxy Offer) "offer",

148+ toDefineExpr (Proxy :: Proxy Decision) "decision",

149+ toDefineExpr (Proxy :: Proxy Room) "room",

150+ toDefineExpr (Proxy :: Proxy Floor) "floor",

151+ toDefineExpr (Proxy :: Proxy Commission) "commission"]

151152 --create the new algebraic data types

152− new_adts = [toAddTypeExpr (undefined :: RoomType),

153− toAddTypeExpr (undefined :: PriceBand),

154− toAddTypeExpr (undefined :: AreaCode),

155− toAddTypeExpr (undefined :: SpeedBand)]

153+ new_adts = [toAddTypeExpr (Proxy :: Proxy RoomType),

154+ toAddTypeExpr (Proxy :: Proxy PriceBand),

155+ toAddTypeExpr (Proxy :: Proxy AreaCode),

156+ toAddTypeExpr (Proxy :: Proxy SpeedBand)]

156157 --create the stored atom functions

157158 priceBandScript = "(\\(DoubleAtom price:_) -> do\n let band = if price < 10000.0 then \"Low\" else if price < 20000.0 then \"Medium\" else if price < 30000.0 then \"High\" else \"Premium\"\n let aType = ConstructedAtomType \"PriceBand\" empty\n pure (ConstructedAtom band aType [])) :: [Atom] -> Either AtomFunctionError Atom"

158159 areaCodeScript = "(\\(TextAtom address:_) -> let aType = ConstructedAtomType \"AreaCode\" empty in if address == \"90210\" then pure (ConstructedAtom \"City\" aType []) else pure (ConstructedAtom \"Rural\" aType [])) :: [Atom] -> Either AtomFunctionError Atom"

src/lib/ProjectM36/Atomable.hs+22−20

@@ -3,7 +3,6 @@ module ProjectM36.Atomable where

33--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data

44--instances to marshal Haskell ADTs to ConstructedAtoms and back

55import ProjectM36.Base

6−import ProjectM36.Relation

76import ProjectM36.DataTypes.Primitive

87import ProjectM36.DataTypes.List

98import ProjectM36.DataTypes.Maybe

@@ -18,6 +17,7 @@ import Data.Time.Calendar

1817import Data.ByteString (ByteString)

1918import Data.Time.Clock

2019import Data.Maybe

20+import Data.Proxy

2121

2222--also add haskell scripting atomable support

2323--rename this module to Atomable along with test

@@ -47,14 +47,14 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where

4747 Nothing -> error "no fromAtomG for Atom found"

4848 Just x -> to x

4949

50− toAtomType :: a -> AtomType

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

52− toAtomType v = toAtomTypeG (from v)

50+ toAtomType :: proxy a -> AtomType

51+ default toAtomType :: (Generic a, AtomableG (Rep a)) => proxy a -> AtomType

52+ toAtomType _ = toAtomTypeG (from (undefined :: a))

5353

5454 -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.

55− toAddTypeExpr :: a -> DatabaseContextExpr

56− default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr

57− toAddTypeExpr v = toAddTypeExprG (from v) (toAtomType v)

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

5858

5959instance Atomable Integer where

6060 toAtom = IntegerAtom

@@ -112,6 +112,7 @@ instance Atomable Bool where

112112 toAtomType _ = BoolAtomType

113113 toAddTypeExpr _ = NoOperation

114114

115+{-

115116instance Atomable Relation where

116117 toAtom = RelationAtom

117118 fromAtom (RelationAtom r) = r

@@ -119,23 +120,24 @@ instance Atomable Relation where

119120 --warning: cannot be used with undefined "Relation"

120121 toAtomType rel = RelationAtomType (attributes rel)

121122 toAddTypeExpr _ = NoOperation

123+-}

122124

123125instance Atomable a => Atomable (Maybe a) where

124− toAtom (Just v) = ConstructedAtom "Just" (maybeAtomType (toAtomType v)) [toAtom v]

125− toAtom Nothing = ConstructedAtom "Nothing" (maybeAtomType (toAtomType (undefined :: a))) []

126+ toAtom (Just v) = ConstructedAtom "Just" (maybeAtomType (toAtomType (Proxy :: Proxy a))) [toAtom v]

127+ toAtom Nothing = ConstructedAtom "Nothing" (maybeAtomType (toAtomType (Proxy :: Proxy a))) []

126128

127129 fromAtom (ConstructedAtom "Just" _ [val]) = Just (fromAtom val)

128130 fromAtom (ConstructedAtom "Nothing" _ []) = Nothing

129131 fromAtom _ = error "improper fromAtom (Maybe a)"

130132

131− toAtomType _ = ConstructedAtomType "Maybe" (M.singleton "a" (toAtomType (undefined :: a)))

133+ toAtomType _ = ConstructedAtomType "Maybe" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

132134 toAddTypeExpr _ = NoOperation

133135

134136instance (Atomable a, Atomable b) => Atomable (Either a b) where

135− toAtom (Left l) = ConstructedAtom "Left" (eitherAtomType (toAtomType (undefined :: a))

136− (toAtomType (undefined :: b))) [toAtom l]

137− toAtom (Right r) = ConstructedAtom "Right" (eitherAtomType (toAtomType (undefined :: a))

138− (toAtomType (undefined :: b))) [toAtom r]

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]

139141

140142 fromAtom (ConstructedAtom "Left" _ [val]) = Left (fromAtom val)

141143 fromAtom (ConstructedAtom "Right" _ [val]) = Right (fromAtom val)

@@ -143,14 +145,14 @@ instance (Atomable a, Atomable b) => Atomable (Either a b) where

143145

144146--convert to ADT list

145147instance Atomable a => Atomable [a] where

146− toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (undefined :: a))) []

147− toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType x)) (map toAtom (x:xs))

148+ toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (Proxy :: Proxy a))) []

149+ toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs))

148150

149151 fromAtom (ConstructedAtom "Empty" _ _) = []

150152 fromAtom (ConstructedAtom "Cons" _ (x:xs)) = fromAtom x:map fromAtom xs

151153 fromAtom _ = error "improper fromAtom [a]"

152154

153− toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (undefined :: a)))

155+ toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))

154156 toAddTypeExpr _ = NoOperation

155157

156158-- Generics

@@ -220,13 +222,13 @@ instance (Atomable a) => AtomableG (K1 c a) where

220222 where headatom (x:_) = x

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

222224 toAtomsG (K1 v) = [toAtom v]

223− toAtomTypeG _ = toAtomType (undefined :: a)

225+ toAtomTypeG _ = toAtomType (Proxy :: Proxy a)

224226 toAddTypeExprG _ _ = undefined

225227 getConstructorsG = undefined

226− getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons]

228+ getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]

227229 where

228230 tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType

229− primitiveAType = toAtomType v

231+ primitiveAType = toAtomType (Proxy :: Proxy a)

230232 primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping)

231233

232234instance AtomableG U1 where

src/lib/ProjectM36/Tupleable.hs+24−14

@@ -2,8 +2,8 @@

22module ProjectM36.Tupleable where

33import ProjectM36.Base

44import ProjectM36.Error

5−import ProjectM36.Tuple

65import ProjectM36.TupleSet

6+import ProjectM36.Tuple

77import ProjectM36.Atomable

88import ProjectM36.DataTypes.Primitive

99import ProjectM36.Attribute hiding (null)

@@ -11,9 +11,12 @@ import GHC.Generics

1111import qualified Data.Vector as V

1212import qualified Data.Text as T

1313import Data.Monoid

14+import Data.Proxy

1415import Data.Foldable

1516

16−{-

17+{-import Data.Binary

18+import Control.DeepSeq

19+

1720data Test1T = Test1C {

1821 attrA :: Int

1922 }

@@ -32,31 +35,38 @@ instance Tupleable Test1T

3235data TestUnnamed1 = TestUnnamed1 Int Double T.Text

3336 deriving (Show,Eq, Generic)

3437

35−instance Tupleable TestUnnamed1

38+instance Tupleable TestUnnamed1

39+

40+data Test7A = Test7AC Integer

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

42+

43+

44+data Test7T = Test7C Test7A

45+ deriving (Generic, Show, Eq)

46+

47+instance Tupleable Test7T

3648-}

3749

3850-- | Convert a 'Traverseable' of 'Tupleable's to an 'Insert' 'DatabaseContextExpr'. This is useful for converting, for example, a list of data values to a set of Insert expressions which can be used to add the values to the database.

39−toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr

51+toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr

4052toInsertExpr vals rvName = do

41− let attrs = toAttributes (head (toList vals))

53+ let attrs = toAttributes (Proxy :: Proxy a)

4254 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)

4355 let rel = MakeStaticRelation attrs tuples

4456 pure (Insert rvName rel)

4557

46−-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'undefined'.

47−toDefineExpr :: Tupleable a => a -> RelVarName -> DatabaseContextExpr

48−toDefineExpr val rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))

58+-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'.

59+toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr

60+toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))

4961 where

50− attrs = toAttributes val

51−

52−

62+ attrs = toAttributes (Proxy :: Proxy a)

5363

5464class Tupleable a where

5565 toTuple :: a -> RelationTuple

5666

5767 fromTuple :: RelationTuple -> Either RelationalError a

5868

59− toAttributes :: a -> Attributes

69+ toAttributes :: proxy a -> Attributes

6070

6171 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple

6272 toTuple v = toTupleG (from v)

@@ -64,8 +74,8 @@ class Tupleable a where

6474 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a

6575 fromTuple tup = to <$> fromTupleG tup

6676

67− default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes

68− toAttributes v = toAttributesG (from v)

77+ default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes

78+ toAttributes _ = toAttributesG (from (undefined :: a))

6979

7080class TupleableG g where

7181 toTupleG :: g a -> RelationTuple

test/Relation/Atomable.hs+3−2

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

1212import Data.Time.Calendar (fromGregorian)

1313import Data.Text

1414import qualified Data.Map as M

15+import Data.Proxy

1516

1617{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

1718data Test1T = Test1C Integer

@@ -67,7 +68,7 @@ testHaskell2DB :: Test

6768testHaskell2DB = TestCase $ do

6869 --validate generated database context expression

6970 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

70− let test1TExpr = toAddTypeExpr (undefined :: Test1T)

71+ let test1TExpr = toAddTypeExpr (Proxy :: Proxy Test1T)

7172 expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Integer" IntegerAtomType)]]

7273 assertEqual "simple ADT1" expectedTest1TExpr test1TExpr

7374 checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr

@@ -83,7 +84,7 @@ testHaskell2DB = TestCase $ do

8384

8485 let retrieveValExpr = Restrict (AttributeEqualityPredicate "a1" (NakedAtomExpr atomVal)) (RelationVariable "x" ())

8586 ret <- executeRelationalExpr sessionId dbconn retrieveValExpr

86− let expectedRel = mkRelationFromList (attributesFromList [Attribute "a1" (toAtomType exampleVal)]) [[atomVal]]

87+ let expectedRel = mkRelationFromList (attributesFromList [Attribute "a1" (toAtomType (Proxy :: Proxy Test1T))]) [[atomVal]]

8788 assertEqual "retrieve atomable atom" expectedRel ret

8889

8990testADT1 :: Test

test/Relation/Tupleable.hs+3−2

@@ -11,6 +11,7 @@ import qualified Data.Vector as V

1111import qualified Data.Map as M

1212import qualified Data.Text as T

1313import System.Exit

14+import Data.Proxy

1415

1516{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

1617

@@ -85,7 +86,7 @@ testADT2 = TestCase $ do

8586 --this was a tricky case that was throwing the undefined exception because of insufficient laziness in the :*: matching- see ProjectM36.Tupleable

8687 let expectedAttributes = attributesFromList [Attribute "attrB" IntegerAtomType,

8788 Attribute "attrC" IntegerAtomType]

88− assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (undefined :: Test2T))

89+ assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (Proxy :: Proxy Test2T))

8990

9091

9192testADT3 :: Test

@@ -110,7 +111,7 @@ testADT7 = TestCase $ do

110111 let example = Test7C (Test7AC 3)

111112 assertEqual "atom type" (Right example) (fromTuple (toTuple example))

112113 let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))

113− assertEqual "adt atomtype" expectedAttrs (toAttributes (undefined :: Test7T))

114+ assertEqual "adt atomtype" expectedAttrs (toAttributes (Proxy :: Proxy Test7T))

114115

115116testADT8 :: Test

116117testADT8 = TestCase $ assertEqual "single value" (Right example) (fromTuple (toTuple example))