git.iko.soy/project-m36
on master help sign in
add priceBand atom function to OotT example
commit4b8b7cfd0876632ed61fb7601d64de54936d08c4 authorAgentM <agentm@themactionfaction.com> dateTue 11 Apr 2017, 17:35 (10 years ago) parent6ea4ad3
5 files changed+34−3
compare with master
unifiedsplit
examples/out_of_the_tarpit.hs+9−1 src/lib/ProjectM36/AtomFunction.hs+8−1 src/lib/ProjectM36/Client.hs+2 src/lib/ProjectM36/DataTypes/Primitive.hs+6 src/lib/ProjectM36/DatabaseContextFunction.hs+9−1
examples/out_of_the_tarpit.hs+9−1
@@ -1,6 +1,7 @@
11-- the Out-of-the-Tarpit example in Haskell and Project:M36
22{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
33import ProjectM36.Client
4+import ProjectM36.DataTypes.Primitive
45import qualified Data.Map as M
56import Data.Maybe
67import Control.Monad
@@ -131,7 +132,14 @@ createSchema sessionId conn = do
131132 toDatabaseContextExpr (undefined :: PriceBand),
132133 toDatabaseContextExpr (undefined :: AreaCode),
133134 toDatabaseContextExpr (undefined :: SpeedBand)]
135+ --create the stored atom functions
136+ 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"
137+ atomFuncs = [createScriptedAtomFunction "priceBandForPrice" [doubleTypeConstructor] (ADTypeConstructor "PriceBand" []) priceBandScript]
134138 --gather up and execute all database updates
135139 mErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
136140 let errs = catMaybes mErrs
137− when (length errs > 0) (error (show errs))
141+ when (length errs > 0) (error (show errs))
142+
143+ mErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs
144+ let errs' = catMaybes mErrs'
145+ when (length errs' > 0) (error (show errs'))
src/lib/ProjectM36/AtomFunction.hs+8−1
@@ -56,4 +56,11 @@ isScriptedAtomFunction func = case atomFuncBody func of
5656
5757atomFunctionScript :: AtomFunction -> Maybe AtomFunctionBodyScript
5858atomFunctionScript func = case atomFuncBody func of
59− AtomFunctionBody script _ -> script
59+ AtomFunctionBody script _ -> script
60+
61+createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr
62+createScriptedAtomFunction funcName argsType retType script = AddAtomFunction funcName (
63+ argsType ++ [ADTypeConstructor "Either" [
64+ TypeConstructorArg (ADTypeConstructor "AtomFunctionError" []),
65+ TypeConstructorArg retType]]) script
66+
src/lib/ProjectM36/Client.hs+2
@@ -65,6 +65,7 @@ module ProjectM36.Client
6565 inclusionDependencyForKey,
6666 databaseContextExprForUniqueKey,
6767 databaseContextExprForForeignKey,
68+ createScriptedAtomFunction,
6869 AttributeExprBase(..),
6970 TypeConstructor(..),
7071 TypeConstructorDef(..),
@@ -86,6 +87,7 @@ import ProjectM36.Base hiding (inclusionDependencies) --defined in this module a
8687import qualified ProjectM36.Base as B
8788import ProjectM36.Error
8889import ProjectM36.Atomable
90+import ProjectM36.AtomFunction
8991import ProjectM36.StaticOptimizer
9092import ProjectM36.Key
9193import qualified ProjectM36.IsomorphicSchema as Schema
src/lib/ProjectM36/DataTypes/Primitive.hs+6
@@ -11,6 +11,12 @@ primitiveTypeConstructorMapping = map (\(name, aType) ->
1111 ("Bool", BoolAtomType),
1212 ("ByteString", ByteStringAtomType)
1313 ]
14+
15+intTypeConstructor :: TypeConstructor
16+intTypeConstructor = PrimitiveTypeConstructor "Int" IntAtomType
17+
18+doubleTypeConstructor :: TypeConstructor
19+doubleTypeConstructor = PrimitiveTypeConstructor "Double" DoubleAtomType
1420
1521-- | Return the type of an 'Atom'.
1622atomTypeForAtom :: Atom -> AtomType
src/lib/ProjectM36/DatabaseContextFunction.hs+9−1
@@ -45,4 +45,12 @@ isScriptedDatabaseContextFunction func = case dbcFuncBody func of
4545
4646databaseContextFunctionScript :: DatabaseContextFunction -> Maybe DatabaseContextFunctionBodyScript
4747databaseContextFunctionScript func = case dbcFuncBody func of
48− DatabaseContextFunctionBody script _ -> script
48+ DatabaseContextFunctionBody script _ -> script
49+
50+databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
51+databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [
52+ TypeConstructorArg (ADTypeConstructor "DatabaseContextFunctionError" []),
53+ TypeConstructorArg tCons]
54+
55+createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr
56+createScriptedDatabaseContextFunction funcName argsIn retArg script = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg]) script