83f8002 · project-m36 · git.iko.soy

git.iko.soy/project-m36

rename ambiguously-named toDatabaseExpr to toAddTypeExpr

commit83f8002f31d7e84158c191ab20847558266e8820 authorAgentM <agentm@themactionfaction.com> dateSat 26 Aug 2017, 07:20 (9 years ago) parenta8fc801

5 files changed+41−39

compare with master

unifiedsplit

docs/new_datatypes.markdown+2−2 examples/hair.hs+1−1 examples/out_of_the_tarpit.hs+16−14 src/lib/ProjectM36/Atomable.hs+21−21 test/Relation/Atomable.hs+1−1

docs/new_datatypes.markdown+2−2

@@ -61,7 +61,7 @@ Note that the ```Atomable``` instance can also be derived.

6161After setting up the connection (which we elide here), the database context is loaded with the expression to define the data type.

6262

6363```haskell

64−executeDatabaseContextExpr sessionId conn (toDatabaseContextExpr (undefined :: Hair))

64+executeDatabaseContextExpr sessionId conn (toAddTypeExpr (undefined :: Hair))

6565```

6666

6767Using a ```Proxy``` would also be acceptable, but the result would be the same.

@@ -104,7 +104,7 @@ The essential ```Atomable``` typeclass functions are:

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 |

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

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

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

108108

109109In 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

examples/hair.hs+1−1

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

2626 sessionId <- eCheck $ createSessionAtHead conn "master"

2727

2828 --create the data type in the database context

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

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

3030

3131 --create a relation with the new Hair AtomType

3232 let blond = NakedAtomExpr (toAtom Blond)

examples/out_of_the_tarpit.hs+16−14

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

1111import Control.DeepSeq

1212import qualified Data.Text as T

1313import Data.Time.Calendar

14−import qualified Data.Vector as V

1514

1615--create various database value (atom) types

1716type Price = Double

@@ -47,6 +46,7 @@ main = do

4746 let sessionId = check eSessionId

4847

4948 createSchema sessionId conn

49+ insertSampleData sessionId conn

5050

5151data Property = Property {

5252 address :: T.Text,

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

142142 ]

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

144144 --define the relvars

145− relvarMap = [("property", toAttributes (undefined :: Property)),

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

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

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

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

150− ("commission", toAttributes (undefined :: Commission))]

151− rvDefs = map (\(name, typ) -> Define name (map NakedAttributeExpr (V.toList typ))) relvarMap

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"]

152151 --create the new algebraic data types

153− new_adts = [toDatabaseContextExpr (undefined :: RoomType),

154− toDatabaseContextExpr (undefined :: PriceBand),

155− toDatabaseContextExpr (undefined :: AreaCode),

156− toDatabaseContextExpr (undefined :: SpeedBand)]

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

153+ toAddTypeExpr (undefined :: PriceBand),

154+ toAddTypeExpr (undefined :: AreaCode),

155+ toAddTypeExpr (undefined :: SpeedBand)]

157156 --create the stored atom functions

158157 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"

159158 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"

@@ -164,11 +163,14 @@ createSchema sessionId conn = do

164163 ]

165164 --gather up and execute all database updates

166165 putStrLn "load relvars"

167− _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)

166+ _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvExprs ++ incDepKeys ++ incDepForeignKeys)

168167

169168 putStrLn "load atom functions"

170169 _ <- handleIOErrors $ mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs

171−

170+ pure ()

171+

172+insertSampleData :: SessionId -> Connection -> IO ()

173+insertSampleData sessionId conn = do

172174 --insert a bunch of records

173175 putStrLn "load data"

174176 let properties = [Property { address = "123 Main St.",

src/lib/ProjectM36/Atomable.hs+21−21

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

5050 toAtomType v = toAtomTypeG (from v)

5151

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

53− toDatabaseContextExpr :: a -> DatabaseContextExpr

54− default toDatabaseContextExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr

55− toDatabaseContextExpr v = toDatabaseContextExprG (from v) (toAtomType v)

53+ toAddTypeExpr :: a -> DatabaseContextExpr

54+ default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr

55+ toAddTypeExpr v = toAddTypeExprG (from v) (toAtomType v)

5656

5757instance Atomable Int where

5858 toAtom = IntAtom

5959 fromAtom (IntAtom i) = i

6060 fromAtom e = error ("improper fromAtom" ++ show e)

6161 toAtomType _ = IntAtomType

62− toDatabaseContextExpr _ = NoOperation

62+ toAddTypeExpr _ = NoOperation

6363

6464instance Atomable Double where

6565 toAtom = DoubleAtom

6666 fromAtom (DoubleAtom d) = d

6767 fromAtom _ = error "improper fromAtom"

6868 toAtomType _ = DoubleAtomType

69− toDatabaseContextExpr _ = NoOperation

69+ toAddTypeExpr _ = NoOperation

7070

7171instance Atomable T.Text where

7272 toAtom = TextAtom

7373 fromAtom (TextAtom t) = t

7474 fromAtom _ = error "improper fromAtom"

7575 toAtomType _ = TextAtomType

76− toDatabaseContextExpr _ = NoOperation

76+ toAddTypeExpr _ = NoOperation

7777

7878instance Atomable Day where

7979 toAtom = DayAtom

8080 fromAtom (DayAtom d) = d

8181 fromAtom _ = error "improper fromAtom"

8282 toAtomType _ = DayAtomType

83− toDatabaseContextExpr _ = NoOperation

83+ toAddTypeExpr _ = NoOperation

8484

8585instance Atomable UTCTime where

8686 toAtom = DateTimeAtom

8787 fromAtom (DateTimeAtom t) = t

8888 fromAtom _ = error "improper fromAtom"

8989 toAtomType _ = DateTimeAtomType

90− toDatabaseContextExpr _ = NoOperation

90+ toAddTypeExpr _ = NoOperation

9191

9292instance Atomable ByteString where

9393 toAtom = ByteStringAtom

9494 fromAtom (ByteStringAtom b) = b

9595 fromAtom _ = error "improper fromAtom"

9696 toAtomType _ = ByteStringAtomType

97− toDatabaseContextExpr _ = NoOperation

97+ toAddTypeExpr _ = NoOperation

9898

9999instance Atomable Bool where

100100 toAtom = BoolAtom

101101 fromAtom (BoolAtom b) = b

102102 fromAtom _ = error "improper fromAtom"

103103 toAtomType _ = BoolAtomType

104− toDatabaseContextExpr _ = NoOperation

104+ toAddTypeExpr _ = NoOperation

105105

106106instance Atomable Relation where

107107 toAtom = RelationAtom

@@ -109,7 +109,7 @@ instance Atomable Relation where

109109 fromAtom _ = error "improper fromAtom"

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

111111 toAtomType rel = RelationAtomType (attributes rel)

112− toDatabaseContextExpr _ = NoOperation

112+ toAddTypeExpr _ = NoOperation

113113

114114--convert to ADT list

115115instance Atomable a => Atomable [a] where

@@ -121,7 +121,7 @@ instance Atomable a => Atomable [a] where

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

122122

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

124− toDatabaseContextExpr _ = NoOperation

124+ toAddTypeExpr _ = NoOperation

125125

126126-- Generics

127127class AtomableG g where

@@ -130,7 +130,7 @@ class AtomableG g where

130130 fromAtomG :: Atom -> [Atom] -> Maybe (g a)

131131 toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType

132132 toAtomsG :: g a -> [Atom]

133− toDatabaseContextExprG :: g a -> AtomType -> DatabaseContextExpr

133+ toAddTypeExprG :: g a -> AtomType -> DatabaseContextExpr

134134 getConstructorsG :: g a -> [DataConstructorDef]

135135 getConstructorArgsG :: g a -> [DataConstructorDefArg]

136136

@@ -142,11 +142,11 @@ instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where

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

143143 where

144144 typeName = datatypeName (undefined :: M1 D c a x)

145− toDatabaseContextExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors

145+ toAddTypeExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors

146146 where

147147 tcDef = ADTypeConstructorDef tcName []

148148 dataConstructors = getConstructorsG v

149− toDatabaseContextExprG _ _ = NoOperation

149+ toAddTypeExprG _ _ = NoOperation

150150 getConstructorsG (M1 v) = getConstructorsG v

151151 getConstructorArgsG = undefined

152152

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

166166 fromAtomG _ _ = error "unsupported generic traversal"

167167 toAtomsG = undefined

168168 toAtomTypeG = undefined

169− toDatabaseContextExprG = undefined

169+ toAddTypeExprG = undefined

170170 getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs]

171171 where

172172 dName = conName (undefined :: M1 C c a x)

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

179179 fromAtomG atom args = M1 <$> fromAtomG atom args

180180 toAtomsG (M1 v) = toAtomsG v

181181 toAtomTypeG (M1 v) = toAtomTypeG v

182− toDatabaseContextExprG _ _ = undefined

182+ toAddTypeExprG _ _ = undefined

183183 getConstructorsG = undefined

184184 getConstructorArgsG (M1 v) = getConstructorArgsG v

185185

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

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

192192 toAtomsG (K1 v) = [toAtom v]

193193 toAtomTypeG _ = toAtomType (undefined :: a)

194− toDatabaseContextExprG _ _ = undefined

194+ toAddTypeExprG _ _ = undefined

195195 getConstructorsG = undefined

196196 getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons]

197197 where

@@ -204,7 +204,7 @@ instance AtomableG U1 where

204204 fromAtomG _ _ = pure U1

205205 toAtomsG _ = []

206206 toAtomTypeG = undefined

207− toDatabaseContextExprG = undefined

207+ toAddTypeExprG = undefined

208208 getConstructorsG = undefined

209209 getConstructorArgsG _ = []

210210

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

218218 tailatoms [] = error "no more atoms in tail for product!"

219219 toAtomTypeG = undefined

220220 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y

221− toDatabaseContextExprG _ _ = undefined

221+ toAddTypeExprG _ _ = undefined

222222 getConstructorsG = undefined

223223 getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y

224224

@@ -230,7 +230,7 @@ instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where

230230 toAtomTypeG = undefined

231231 toAtomsG (L1 x) = toAtomsG x

232232 toAtomsG (R1 x) = toAtomsG x

233− toDatabaseContextExprG _ _ = undefined

233+ toAddTypeExprG _ _ = undefined

234234 getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x)

235235 getConstructorArgsG = undefined

236236

test/Relation/Atomable.hs+1−1

@@ -61,7 +61,7 @@ testHaskell2DB :: Test

6161testHaskell2DB = TestCase $ do

6262 --validate generated database context expression

6363 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

64− let test1TExpr = toDatabaseContextExpr (undefined :: Test1T)

64+ let test1TExpr = toAddTypeExpr (undefined :: Test1T)

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

6666 assertEqual "simple ADT1" expectedTest1TExpr test1TExpr

6767 checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr