git.iko.soy/project-m36
on master help sign in
WIP compilation checkpoint tutd

switching to compiling project-m36 library as a dependency for executables switched to Atom ADT AtomFunctionBody somewhat working

commitaed876285bd681f29ee2bea8106dd2cfb92e3c70 authorAgentM <agentm@themactionfaction.com> dateSat 20 Aug 2016, 15:48 (10 years ago) parent2420391
89 files changed+388−296
compare with master
unifiedsplit
Database/Persist/ProjectM36.hs+15−22 ProjectM36/Server/RemoteCallTypes/Json.hs−159 benchmark/bigrel.hs+4−4 ProjectM36/DirectoryFsync.c → cbits/DirectoryFsync.c examples/PersistClient.hs+1−1 examples/SimpleClient.hs+4−6 project-m36.cabal+21−65 TutorialD/Interpreter.hs → src/bin/TutorialD/Interpreter.hs+1−1 TutorialD/Interpreter/Base.hs → src/bin/TutorialD/Interpreter/Base.hs TutorialD/Interpreter/DataTypes/DateTime.hs → src/bin/TutorialD/Interpreter/DataTypes/DateTime.hs TutorialD/Interpreter/DataTypes/Interval.hs → src/bin/TutorialD/Interpreter/DataTypes/Interval.hs TutorialD/Interpreter/DatabaseContextExpr.hs → src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+5−2 src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+45 TutorialD/Interpreter/Export/Base.hs → src/bin/TutorialD/Interpreter/Export/Base.hs TutorialD/Interpreter/Export/CSV.hs → src/bin/TutorialD/Interpreter/Export/CSV.hs TutorialD/Interpreter/Import/Base.hs → src/bin/TutorialD/Interpreter/Import/Base.hs TutorialD/Interpreter/Import/BasicExamples.hs → src/bin/TutorialD/Interpreter/Import/BasicExamples.hs TutorialD/Interpreter/Import/CSV.hs → src/bin/TutorialD/Interpreter/Import/CSV.hs TutorialD/Interpreter/Import/TutorialD.hs → src/bin/TutorialD/Interpreter/Import/TutorialD.hs TutorialD/Interpreter/InformationOperator.hs → src/bin/TutorialD/Interpreter/InformationOperator.hs TutorialD/Interpreter/RODatabaseContextOperator.hs → src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs TutorialD/Interpreter/RelationalExpr.hs → src/bin/TutorialD/Interpreter/RelationalExpr.hs TutorialD/Interpreter/TransactionGraphOperator.hs → src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs TutorialD/Interpreter/Types.hs → src/bin/TutorialD/Interpreter/Types.hs TutorialD/tutd.hs → src/bin/TutorialD/tutd.hs ProjectM36/Atom.hs → src/lib/ProjectM36/Atom.hs ProjectM36/AtomFunction.hs → src/lib/ProjectM36/AtomFunction.hs ProjectM36/AtomFunctionBody.hs → src/lib/ProjectM36/AtomFunctionBody.hs+50−31 ProjectM36/AtomFunctions/Basic.hs → src/lib/ProjectM36/AtomFunctions/Basic.hs ProjectM36/AtomFunctions/Primitive.hs → src/lib/ProjectM36/AtomFunctions/Primitive.hs ProjectM36/AtomType.hs → src/lib/ProjectM36/AtomType.hs ProjectM36/Attribute.hs → src/lib/ProjectM36/Attribute.hs ProjectM36/AttributeNames.hs → src/lib/ProjectM36/AttributeNames.hs ProjectM36/Base.hs → src/lib/ProjectM36/Base.hs ProjectM36/Client.hs → src/lib/ProjectM36/Client.hs ProjectM36/Client/Json.hs → src/lib/ProjectM36/Client/Json.hs ProjectM36/ConcreteTypeRep.hs → src/lib/ProjectM36/ConcreteTypeRep.hs ProjectM36/DataConstructorDef.hs → src/lib/ProjectM36/DataConstructorDef.hs ProjectM36/DataTypes/Basic.hs → src/lib/ProjectM36/DataTypes/Basic.hs ProjectM36/DataTypes/Day.hs → src/lib/ProjectM36/DataTypes/Day.hs ProjectM36/DataTypes/Either.hs → src/lib/ProjectM36/DataTypes/Either.hs ProjectM36/DataTypes/Interval.hs → src/lib/ProjectM36/DataTypes/Interval.hs ProjectM36/DataTypes/Maybe.hs → src/lib/ProjectM36/DataTypes/Maybe.hs ProjectM36/DataTypes/Primitive.hs → src/lib/ProjectM36/DataTypes/Primitive.hs ProjectM36/DatabaseContext.hs → src/lib/ProjectM36/DatabaseContext.hs ProjectM36/DateExamples.hs → src/lib/ProjectM36/DateExamples.hs ProjectM36/Error.hs → src/lib/ProjectM36/Error.hs ProjectM36/Key.hs → src/lib/ProjectM36/Key.hs ProjectM36/MiscUtils.hs → src/lib/ProjectM36/MiscUtils.hs ProjectM36/Notifications.hs → src/lib/ProjectM36/Notifications.hs ProjectM36/Persist.hs → src/lib/ProjectM36/Persist.hs ProjectM36/Relation.hs → src/lib/ProjectM36/Relation.hs ProjectM36/Relation/Parse/CSV.hs → src/lib/ProjectM36/Relation/Parse/CSV.hs ProjectM36/Relation/Show/CSV.hs → src/lib/ProjectM36/Relation/Show/CSV.hs ProjectM36/Relation/Show/Gnuplot.hs → src/lib/ProjectM36/Relation/Show/Gnuplot.hs ProjectM36/Relation/Show/HTML.hs → src/lib/ProjectM36/Relation/Show/HTML.hs ProjectM36/Relation/Show/Term.hs → src/lib/ProjectM36/Relation/Show/Term.hs ProjectM36/RelationalExpression.hs → src/lib/ProjectM36/RelationalExpression.hs+4−4 ProjectM36/ScriptBase.hs → src/lib/ProjectM36/ScriptBase.hs ProjectM36/Server.hs → src/lib/ProjectM36/Server.hs src/lib/ProjectM36/Server/#WebSocket.hs#+89 ProjectM36/Server/Config.hs → src/lib/ProjectM36/Server/Config.hs ProjectM36/Server/EntryPoints.hs → src/lib/ProjectM36/Server/EntryPoints.hs+1−1 src/lib/ProjectM36/Server/EntryPoints/Json.hs ProjectM36/Server/ParseArgs.hs → src/lib/ProjectM36/Server/ParseArgs.hs ProjectM36/Server/RemoteCallTypes.hs → src/lib/ProjectM36/Server/RemoteCallTypes.hs src/lib/ProjectM36/Server/RemoteCallTypes/Json.hs+134 ProjectM36/Server/WebSocket.hs → src/lib/ProjectM36/Server/WebSocket.hs ProjectM36/Server/WebSocket/Main.hs → src/lib/ProjectM36/Server/WebSocket/Main.hs ProjectM36/Server/WebSocket/project-m36.js → src/lib/ProjectM36/Server/WebSocket/project-m36.js ProjectM36/Server/WebSocket/websocket-client.html → src/lib/ProjectM36/Server/WebSocket/websocket-client.html ProjectM36/Server/WebSocket/websocket-client.js → src/lib/ProjectM36/Server/WebSocket/websocket-client.js ProjectM36/Server/project-m36-server.hs → src/lib/ProjectM36/Server/project-m36-server.hs ProjectM36/Session.hs → src/lib/ProjectM36/Session.hs ProjectM36/Sessions.hs → src/lib/ProjectM36/Sessions.hs ProjectM36/StaticOptimizer.hs → src/lib/ProjectM36/StaticOptimizer.hs ProjectM36/Transaction.hs → src/lib/ProjectM36/Transaction.hs ProjectM36/Transaction/Persist.hs → src/lib/ProjectM36/Transaction/Persist.hs ProjectM36/TransactionGraph.hs → src/lib/ProjectM36/TransactionGraph.hs ProjectM36/TransactionGraph/Merge.hs → src/lib/ProjectM36/TransactionGraph/Merge.hs ProjectM36/TransactionGraph/Persist.hs → src/lib/ProjectM36/TransactionGraph/Persist.hs ProjectM36/TransactionGraph/Show.hs → src/lib/ProjectM36/TransactionGraph/Show.hs ProjectM36/TransactionGraph/Show/Dot.hs → src/lib/ProjectM36/TransactionGraph/Show/Dot.hs ProjectM36/Tuple.hs → src/lib/ProjectM36/Tuple.hs ProjectM36/TupleSet.hs → src/lib/ProjectM36/TupleSet.hs ProjectM36/TypeConstructor.hs → src/lib/ProjectM36/TypeConstructor.hs ProjectM36/TypeConstructorDef.hs → src/lib/ProjectM36/TypeConstructorDef.hs src/lib/ProjectM36/WebSocketServer.hs+14 ProjectM36/Win32Handle.hs → src/lib/ProjectM36/Win32Handle.hs
Database/Persist/ProjectM36.hs+15−22
@@ -31,9 +31,6 @@ import Control.Monad.Trans.Either
3131import qualified Database.Persist.Types as DPT
3232import qualified Data.Set as S
3333import qualified Data.Conduit.List as CL
34−import Data.Typeable (typeRep, typeOf, Proxy(..))
35−import Data.Time.Calendar (Day)
36−import Data.ByteString (ByteString)
3734import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceWithPrefix, readTextData)
3835
3936type ProjectM36Backend = (C.SessionId, C.Connection)
@@ -55,7 +52,7 @@ recordAttributes entInfo record = do
5552 let convertAttr = uncurry fieldDefAsAttribute
5653 idDBName = unDBName $ fieldDB $ entityId (entityDef $ Just record)
5754 attrList <- mapM convertAttr entInfo
58− return $ V.fromList ([Attribute idDBName textAtomType] ++ attrList)
55+ return $ V.fromList ([Attribute idDBName TextAtomType] ++ attrList)
5956
6057fieldDefAsAttribute :: EmbedFieldDef -> PersistValue -> Either RelationalError Attribute
6158fieldDefAsAttribute fieldDef pVal = case persistValueAtomType pVal of
@@ -71,27 +68,23 @@ persistValueAtomType val = do
7168
7269persistValueAtom :: PersistValue -> Maybe Atom
7370persistValueAtom val = case val of
74− PersistText v -> return $ Atom v
75− PersistInt64 v -> return $ Atom ((fromIntegral v)::Int)
76− PersistBool v -> return $ Atom v
77− PersistDay v -> return $ Atom v
71+ PersistText v -> return $ TextAtom v
72+ PersistInt64 v -> return $ IntAtom ((fromIntegral v)::Int)
73+ PersistBool v -> return $ BoolAtom v
74+ PersistDay v -> return $ DayAtom v
7875 _ -> Nothing
7976
8077atomAsPersistValue :: Atom -> PersistValue
8178--constructed atoms are written as text to the database
8279atomAsPersistValue atom@(ConstructedAtom _ _ _) = PersistText (atomToText atom)
83−atomAsPersistValue atom@(Atom atomv) = if typeRep (Proxy :: Proxy Int) == typeOf atomv then
84− PersistInt64 (fromIntegral ((unsafeCast atom) :: Int))
85− else if typeRep (Proxy :: Proxy T.Text) == typeOf atomv then
86− PersistText (unsafeCast atom)
87− else if typeRep (Proxy :: Proxy Bool) == typeOf atomv then
88− PersistBool (unsafeCast atom)
89− else if typeRep (Proxy :: Proxy Day) == typeOf atomv then
90− PersistDay (unsafeCast atom)
91− else if typeRep (Proxy :: Proxy ByteString) == typeOf atomv then
92− PersistByteString (unsafeCast atom)
93− else
94− error "missing conversion"
80+atomAsPersistValue (IntAtom i) = PersistInt64 (fromIntegral i)
81+atomAsPersistValue (DoubleAtom i) = PersistDouble i
82+atomAsPersistValue (TextAtom i) = PersistText i
83+atomAsPersistValue (DayAtom i) = PersistDay i
84+atomAsPersistValue (DateTimeAtom i) = PersistUTCTime i
85+atomAsPersistValue (ByteStringAtom i) = PersistByteString i
86+atomAsPersistValue (BoolAtom i) = PersistBool i
87+atomAsPersistValue _ = error "Persist: missing conversion"
9588
9689recordAsAtoms :: forall record. (PersistEntity record, PersistEntityBackend record ~ ProjectM36Backend)
9790 => Maybe U.UUID -> Attributes -> record -> Either RelationalError (V.Vector Atom)
@@ -103,7 +96,7 @@ recordAsAtoms freshUUID _ record = do
10396 atoms <- mapM valAtom pValues
10497 return $ V.fromList $ case freshUUID of
10598 Nothing -> atoms
106− Just uuid -> [Atom $ T.pack (U.toString uuid)] ++ atoms
99+ Just uuid -> [TextAtom $ T.pack (U.toString uuid)] ++ atoms
107100
108101--used by insert operations
109102recordsAsRelation :: forall record. (PersistEntity record, PersistEntityBackend record ~ ProjectM36Backend) =>
@@ -182,7 +175,7 @@ commonKeyQueryProperties key = do
182175 relVarName = unDBName $ entityDB entityInfo
183176 matchUUIDText = T.pack $ U.toString matchUUID
184177 entityInfo = entityDefFromKey key
185− restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (Atom matchUUIDText))
178+ restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (TextAtom matchUUIDText))
186179 return (relVarName, restrictionPredicate)
187180
188181deleteByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ ProjectM36Backend, PersistEntity val) => Key val -> ReaderT ProjectM36Backend m (Bool)
ProjectM36/Server/RemoteCallTypes/Json.hsdeleted−159
@@ -1,159 +0,0 @@
1−--create a bunch of orphan instances for use with the websocket server
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3−module ProjectM36.Server.RemoteCallTypes.Json where
4−import ProjectM36.Server.RemoteCallTypes
5−import ProjectM36.Base
6−import ProjectM36.ConcreteTypeRep
7−import ProjectM36.Error
8−
9−import Data.Aeson
10−import Data.UUID.Aeson ()
11−import Data.Proxy
12−import Data.Typeable
13−import Data.Text
14−import Data.Time.Calendar
15−import ProjectM36.Atom
16−import ProjectM36.DataTypes.Primitive
17−import ProjectM36.AtomFunctions.Primitive
18−import ProjectM36.DataTypes.Day
19−import Data.ByteString
20−
21−instance ToJSON RelationalExpr
22−instance FromJSON RelationalExpr
23−
24−instance ToJSON TupleExpr
25−instance FromJSON TupleExpr
26−
27−instance ToJSON RestrictionPredicateExpr
28−instance FromJSON RestrictionPredicateExpr
29−
30−instance ToJSON AtomExpr
31−instance FromJSON AtomExpr
32−
33−instance ToJSON RelationTupleSet
34−instance FromJSON RelationTupleSet
35−
36−instance ToJSON RelationTuple
37−instance FromJSON RelationTuple
38−
39−instance ToJSON ExecuteRelationalExpr
40−instance FromJSON ExecuteRelationalExpr
41−
42−instance ToJSON Relation
43−instance FromJSON Relation
44−
45−instance ToJSON Attribute
46−instance FromJSON Attribute
47−
48−instance ToJSON ExtendTupleExpr
49−instance FromJSON ExtendTupleExpr
50−
51−instance ToJSON AttributeNames
52−instance FromJSON AttributeNames
53−
54−instance ToJSON AttributeExpr
55−instance FromJSON AttributeExpr
56−
57−instance ToJSON AtomType
58−instance FromJSON AtomType
59−
60−instance ToJSON TypeConstructor
61−instance FromJSON TypeConstructor
62−
63−instance ToJSON TypeConstructorArg
64−instance FromJSON TypeConstructorArg
65−
66−instance ToJSON SerialRep
67−instance FromJSON SerialRep
68−
69−instance FromJSON ConcreteTypeRep where
70− parseJSON = withObject "ctr" $ \o -> do
71− serialRep <- o .: "serialrep"
72− pure $ fromSerial serialRep
73−
74−instance ToJSON ConcreteTypeRep where
75− toJSON ctr = object [
76− "serialrep" .= toSerial ctr
77− ]
78−
79−instance ToJSON Atom where
80− toJSON atom@(Atom _) = let atype = atomTypeForAtom atom
81− in
82− if atype == intAtomType then
83− object [
84− "type" .= atype,
85− "val" .= ((unsafeCast atom) :: Int)]
86− else if atype == textAtomType then
87− object [
88− "type" .= atype,
89− "val" .= ((unsafeCast atom) :: Text)]
90− else if atype == doubleAtomType then
91− object [
92− "type" .= atype,
93− "val" .= ((unsafeCast atom) :: Double)]
94− else if atype == dayAtomType then
95− object [
96− "type" .= atype,
97− "val" .= ((unsafeCast atom) :: Day)]
98− else if atype == byteStringAtomType then
99− object [
100− "type" .= atype,
101− "val" .= toText ((unsafeCast atom) :: ByteString)]
102− else if atype == boolAtomType then
103− object [
104− "type" .= atype,
105− "val" .= ((unsafeCast atom) :: Bool)]
106− else if isRelationAtomType atype then
107− object [
108− "type" .= atype,
109− "val" .= castRelation atom ]
110− else error "invalid primitive in ToJSON implementation"
111−
112− toJSON (ConstructedAtom dConsName atomtype atomlist) = object [
113− "dataconstructorname" .= dConsName,
114− "type" .= toJSON atomtype,
115− "atomlist" .= toJSON atomlist
116− ]
117−
118−instance FromJSON Atom where
119− parseJSON = withObject "atom" $ \o -> do
120− atype <- o .: "type"
121− case atype of
122− AnyAtomType -> fail "cannot pass AnyAtomType over the wire"
123− caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"
124− RelationAtomType _ -> do
125− rel <- o .: "val"
126− pure $ Atom (rel :: Relation)
127− AtomType cTypeRep -> if unCTR cTypeRep == typeRep (Proxy :: Proxy Int) then
128− intAtom <$> o .: "val"
129− else if unCTR cTypeRep == typeRep (Proxy :: Proxy Text) then
130− textAtom <$> o .: "val"
131− else if unCTR cTypeRep == typeRep (Proxy :: Proxy Double) then
132− doubleAtom <$> o .: "val"
133− else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then
134− dayAtom <$> o .: "val"
135− else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then do
136− txt <- (o .: "val")
137− case (fromText txt) :: Either String ByteString of
138− Left err -> fail $ "bytestring parse failure: " ++ show err
139− Right bs -> pure $ byteStringAtom bs
140− else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then
141− boolAtom <$> o .: "val"
142− else
143− error "unsupported typerep serialization"
144−
145−
146−instance ToJSON Notification
147−instance FromJSON Notification
148−
149−instance ToJSON RelationalError
150−instance FromJSON RelationalError
151−
152−instance ToJSON MergeError
153−instance FromJSON MergeError
154−
155−instance ToJSON MergeStrategy
156−instance FromJSON MergeStrategy
157−
158−instance ToJSON PersistenceError
159−
benchmark/bigrel.hs+4−4
@@ -76,7 +76,7 @@ intmapMatrixRun = do
7676intmapMatrixRelation :: Int -> Int -> HS.HashSet (IM.IntMap Atom)
7777intmapMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
7878 where
79− mapper tupCount = IM.fromList $ map (\c-> (c, Atom tupCount)) [0..attributeCount]
79+ mapper tupCount = IM.fromList $ map (\c-> (c, IntAtom tupCount)) [0..attributeCount]
8080
8181instance Hash.Hashable (IM.IntMap Atom) where
8282 hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)
@@ -91,7 +91,7 @@ vectorMatrixRun = do
9191vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom)
9292vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
9393 where
94− mapper tupCount = V.replicate attributeCount (Atom tupCount)
94+ mapper tupCount = V.replicate attributeCount (IntAtom tupCount)
9595
9696instance Hash.Hashable (V.Vector Atom) where
9797 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)
@@ -100,8 +100,8 @@ instance Hash.Hashable (V.Vector Atom) where
100100-- this is useful for performance and resource usage testing
101101matrixRelation :: Int -> Int -> Either RelationalError Relation
102102matrixRelation attributeCount tupleCount = do
103− let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) intAtomType) [0 .. attributeCount-1]
104− tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> Atom tupleX))
103+ let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]
104+ tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))
105105 tuples = map (\c -> tuple c) [0 .. tupleCount]
106106 mkRelationDeferVerify attrs (RelationTupleSet tuples)
107107
ProjectM36/DirectoryFsync.c → cbits/DirectoryFsync.crenamed

The content is the same.

examples/PersistClient.hs+1−1
@@ -27,7 +27,7 @@ errDie out = hPutStrLn stderr out >> exitFailure
2727
2828defPersonRel :: SessionId -> Connection -> IO ()
2929defPersonRel sessionId conn = do
30− let attrList = [Attribute "name" textAtomType, Attribute "age" intAtomType, Attribute "id" textAtomType]
30+ let attrList = [Attribute "name" TextAtomType, Attribute "age" IntAtomType, Attribute "id" TextAtomType]
3131 maybeErr <- executeDatabaseContextExpr sessionId conn (Define "person" (map NakedAttributeExpr attrList))
3232 case maybeErr of
3333 Nothing -> return ()
examples/SimpleClient.hs+4−6
@@ -1,7 +1,5 @@
11import ProjectM36.Client
22import ProjectM36.TupleSet
3−import ProjectM36.Atom
4−import ProjectM36.DataTypes.Primitive
53import ProjectM36.Base
64import ProjectM36.Relation.Show.Term
75
@@ -20,18 +18,18 @@ main = do
2018 Left err -> putStrLn (show err)
2119 Right sessionId -> do
2220 --4. define a new relation variable with a DatabaseContext expression
23− let attrList = [Attribute "name" textAtomType,
24− Attribute "age" intAtomType]
21+ let attrList = [Attribute "name" TextAtomType,
22+ Attribute "age" IntAtomType]
2523 attrs = attributesFromList attrList
2624 mErr1 <- executeDatabaseContextExpr sessionId conn (Define "person" (map NakedAttributeExpr attrList))
2725 putStrLn (show mErr1)
2826 --5. add a tuple to the relation referenced by the relation variable
29− let (Right tupSet) = mkTupleSetFromList attrs [[textAtom "Bob", intAtom 45]]
27+ let (Right tupSet) = mkTupleSetFromList attrs [[TextAtom "Bob", IntAtom 45]]
3028 mErr2 <- executeDatabaseContextExpr sessionId conn (Insert "person" (MakeStaticRelation attrs tupSet))
3129 putStrLn (show mErr2)
3230
3331 --6. execute a relational algebra query
34− let restrictionPredicate = AttributeEqualityPredicate "name" (NakedAtomExpr (textAtom "Steve"))
32+ let restrictionPredicate = AttributeEqualityPredicate "name" (NakedAtomExpr (TextAtom "Steve"))
3533 eRel <- executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "person"))
3634 case eRel of
3735 Left err -> putStrLn (show err)
project-m36.cabal+21−65
@@ -81,6 +81,8 @@ Library
8181 ProjectM36.AtomFunction,
8282 ProjectM36.Key,
8383 ProjectM36.DatabaseContext,
84+ ProjectM36.DateExamples,
85+ ProjectM36.AtomFunctionBody,
8486 ProjectM36.RelationalExpression,
8587 ProjectM36.Relation.Show.HTML,
8688 ProjectM36.StaticOptimizer,
@@ -109,15 +111,16 @@ Library
109111 ProjectM36.Transaction.Persist,
110112 ProjectM36.TypeConstructor,
111113 ProjectM36.TypeConstructorDef,
112− ProjectM36.TransactionGraph.Merge,
113− Database.Persist.ProjectM36
114+ ProjectM36.TransactionGraph.Merge
114115 GHC-Options: -Wall -rtsopts
115116 if os(windows)
116117 Build-Depends: Win32 >= 2.3 && < 2.4
117118 Other-Modules: ProjectM36.Win32Handle
118119 else
119− C-sources: ProjectM36/DirectoryFsync.c
120+ C-sources: cbits/DirectoryFsync.c
120121 Build-Depends: unix
122+ CC-Options: -fPIC
123+ Hs-Source-Dirs: ./src/lib
121124 Default-Language: Haskell2010
122125 Default-Extensions: OverloadedStrings
123126
@@ -125,6 +128,7 @@ Executable tutd
125128 Build-Depends: base >=4.8 && <4.9,
126129 ghc >= 7.8 && <= 8.0.1,
127130 ghc-paths,
131+ project-m36,
128132 containers,
129133 unordered-containers,
130134 hashable,
@@ -162,55 +166,13 @@ Executable tutd
162166 attoparsec,
163167 stm-containers,
164168 list-t
165− Other-Modules: ProjectM36.Error,
166− ProjectM36.Base,
167− ProjectM36.RelationalExpression,
168− ProjectM36.Transaction,
169− TutorialD.Interpreter,
169+ Other-Modules: TutorialD.Interpreter,
170170 TutorialD.Interpreter.Base,
171171 TutorialD.Interpreter.DatabaseContextExpr,
172172 TutorialD.Interpreter.RODatabaseContextOperator,
173173 TutorialD.Interpreter.TransactionGraphOperator,
174174 TutorialD.Interpreter.DataTypes.Interval,
175175 TutorialD.Interpreter.DataTypes.DateTime,
176− ProjectM36.Atom,
177− ProjectM36.AtomFunction,
178− ProjectM36.AtomFunctions.Basic,
179− ProjectM36.AtomFunctions.Primitive,
180− ProjectM36.AtomType,
181− ProjectM36.Attribute,
182− ProjectM36.AttributeNames,
183− ProjectM36.Client,
184− ProjectM36.ConcreteTypeRep,
185− ProjectM36.DataConstructorDef,
186− ProjectM36.DataTypes.Basic,
187− ProjectM36.DataTypes.Day,
188− ProjectM36.DataTypes.Either,
189− ProjectM36.DataTypes.Maybe,
190− ProjectM36.DataTypes.Primitive,
191− ProjectM36.DatabaseContext,
192− ProjectM36.Key,
193− ProjectM36.MiscUtils,
194− ProjectM36.Notifications,
195− ProjectM36.Persist,
196− ProjectM36.Relation,
197− ProjectM36.Relation.Parse.CSV,
198− ProjectM36.Relation.Show.CSV,
199− ProjectM36.Relation.Show.Gnuplot,
200− ProjectM36.Relation.Show.Term,
201− ProjectM36.Server.RemoteCallTypes,
202− ProjectM36.Session,
203− ProjectM36.Sessions,
204− ProjectM36.StaticOptimizer,
205− ProjectM36.Transaction.Persist,
206− ProjectM36.TransactionGraph,
207− ProjectM36.TransactionGraph.Persist,
208− ProjectM36.Tuple,
209− ProjectM36.TupleSet,
210− ProjectM36.TypeConstructor,
211− ProjectM36.TypeConstructorDef,
212− ProjectM36.TransactionGraph.Merge,
213− ProjectM36.DateExamples,
214176 TutorialD.Interpreter.Import.BasicExamples,
215177 TutorialD.Interpreter.InformationOperator,
216178 TutorialD.Interpreter.Export.Base,
@@ -224,18 +186,21 @@ Executable tutd
224186 CPP-Options: -DPROJECTM36_VERSION="v0.1"
225187 CC-Options: -fPIC
226188 GHC-Options: -Wall
189+ Hs-Source-Dirs: ./src/bin
227190 Default-Language: Haskell2010
228191 Default-Extensions: OverloadedStrings
229− if os(windows)
230− Build-Depends: Win32 >= 2.3 && < 2.4
231− Other-Modules: ProjectM36.Win32Handle
232− else
233− C-sources: ProjectM36/DirectoryFsync.c
234− Build-Depends: unix
192+-- if os(windows)
193+-- Build-Depends: Win32 >= 2.3 && < 2.4
194+-- Other-Modules: ProjectM36.Win32Handle
195+-- else
196+-- C-sources: ProjectM36/DirectoryFsync.c
197+-- Build-Depends: unix
235198
236199
237200Executable project-m36-server
238201 Build-Depends: base,
202+ ghc >= 7.8 && <= 8.0.1,
203+ ghc-paths,
239204 distributed-process-client-server,
240205 distributed-process-extras,
241206 distributed-process-async,
@@ -326,7 +291,7 @@ Executable project-m36-server
326291Executable bigrel
327292 Default-Language: Haskell2010
328293 Default-Extensions: OverloadedStrings
329− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t
294+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers
330295 Other-Modules: ProjectM36.Base,
331296 ProjectM36.Relation
332297 ProjectM36.Tuple,
@@ -515,12 +480,10 @@ Test-Suite test-server
515480 C-sources: ProjectM36/DirectoryFsync.c
516481 Build-Depends: unix
517482
518−
519−
520483Executable Example-SimpleClient
521484 Default-Language: Haskell2010
522485 Default-Extensions: OverloadedStrings
523− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t
486+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths
524487 Main-Is: examples/SimpleClient.hs
525488 GHC-Options: -Wall
526489 CPP-Options: -DPROJECTM36_VERSION="v0.1"
@@ -573,7 +536,7 @@ Executable Example-SimpleClient
573536Executable Example-PersistClient
574537 Default-Language: Haskell2010
575538 Default-Extensions: OverloadedStrings
576− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template
539+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template, ghc, ghc-paths
577540 Main-Is: examples/PersistClient.hs
578541 GHC-Options: -Wall
579542 CPP-Options: -DPROJECTM36_VERSION="v0.1"
@@ -637,16 +600,9 @@ Test-Suite test-scripts
637600 C-sources: ProjectM36/DirectoryFsync.c
638601 Build-Depends: unix
639602
640−Executable dud
641− Default-Language: Haskell2010
642− Build-Depends: ghc >= 7.8 && <= 8.0.1, base, ghc-paths, mtl, haskeline
643− Main-Is: test.hs
644− GHC-Options: -Wall
645− CPP-Options: -DGHCI
646−
647603Executable project-m36-websocket-server
648604 Default-Language: Haskell2010
649− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template, websockets, aeson, uuid-aeson, optparse-applicative
605+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template, websockets, aeson, uuid-aeson, optparse-applicative, ghc, ghc-paths
650606 Other-Modules: ProjectM36.Atom, ProjectM36.AtomFunction, ProjectM36.AtomFunctions.Basic, ProjectM36.AtomFunctions.Primitive, ProjectM36.AtomType, ProjectM36.Attribute, ProjectM36.AttributeNames, ProjectM36.Base, ProjectM36.Client, ProjectM36.Client.Json, ProjectM36.ConcreteTypeRep, ProjectM36.DataConstructorDef, ProjectM36.DataTypes.Basic, ProjectM36.DataTypes.Day, ProjectM36.DataTypes.Either, ProjectM36.DataTypes.Maybe, ProjectM36.DataTypes.Primitive, ProjectM36.DatabaseContext, ProjectM36.DateExamples, ProjectM36.Error, ProjectM36.Key, ProjectM36.MiscUtils, ProjectM36.Notifications, ProjectM36.Persist, ProjectM36.Relation, ProjectM36.Relation.Parse.CSV, ProjectM36.Relation.Show.CSV, ProjectM36.Relation.Show.Gnuplot, ProjectM36.Relation.Show.Term, ProjectM36.RelationalExpression, ProjectM36.Server, ProjectM36.Server.Config, ProjectM36.Server.EntryPoints, ProjectM36.Server.ParseArgs, ProjectM36.Server.RemoteCallTypes, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, ProjectM36.Session, ProjectM36.Sessions, ProjectM36.StaticOptimizer, ProjectM36.Transaction, ProjectM36.Transaction.Persist, ProjectM36.TransactionGraph, ProjectM36.TransactionGraph.Merge, ProjectM36.TransactionGraph.Persist, ProjectM36.Tuple, ProjectM36.TupleSet, ProjectM36.TypeConstructor, ProjectM36.TypeConstructorDef, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types
651607 Main-Is: ProjectM36/Server/WebSocket/Main.hs
652608 GHC-Options: -Wall
TutorialD/Interpreter.hs → src/bin/TutorialD/Interpreter.hsrenamed+1−1
@@ -51,7 +51,7 @@ interpreterParserP = safeInterpreterParserP <|>
5151 liftM ImportRelVarOp (importCSVP <* eof) <|>
5252 liftM ImportDBContextOp (tutdImportP <* eof) <|>
5353 liftM RelVarExportOp (exportCSVP <* eof) <|>
54− liftM DatabaseContextIOExprOp (parseCreateAtomFunctionExpr <* eof)
54+ liftM DatabaseContextIOExprOp (addAtomFunctionExprP <* eof)
5555
5656-- the safe interpreter never reads or writes the file system
5757safeInterpreterParserP :: Parser ParsedOperation
TutorialD/Interpreter/Base.hs → src/bin/TutorialD/Interpreter/Base.hsrenamed

The content is the same.

TutorialD/Interpreter/DataTypes/DateTime.hs → src/bin/TutorialD/Interpreter/DataTypes/DateTime.hsrenamed

The content is the same.

TutorialD/Interpreter/DataTypes/Interval.hs → src/bin/TutorialD/Interpreter/DataTypes/Interval.hsrenamed

The content is the same.

TutorialD/Interpreter/DatabaseContextExpr.hs → src/bin/TutorialD/Interpreter/DatabaseContextExpr.hsrenamed+5−2
@@ -103,8 +103,6 @@ addConstraintP = do
103103 SubsetOp -> pure subsetA
104104 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
105105
106−
107−
108106deleteConstraintP :: Parser DatabaseContextExpr
109107deleteConstraintP = do
110108 reserved "deleteconstraint"
@@ -155,6 +153,11 @@ removeTypeConstructorP :: Parser DatabaseContextExpr
155153removeTypeConstructorP = do
156154 reserved "undata"
157155 RemoveTypeConstructor <$> liftM T.pack identifier
156+
157+removeAtomFunctionP :: Parser DatabaseContextExpr
158+removeAtomFunctionP = do
159+ reserved "removeatomfunction"
160+ RemoveAtomFunction <$> liftM T.pack quotedString
158161
159162databaseExprOpP :: Parser DatabaseContextExpr
160163databaseExprOpP = multipleDatabaseContextExprP
src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hsnew file+45
@@ -0,0 +1,45 @@
1+--compiling the script requires the IO monad because it must load modules from the filesystem, so we create the function and generate the requisite DatabaseExpr here.
2+module TutorialD.Interpreter.DatabaseContextIOOperator where
3+import ProjectM36.Base
4+
5+import TutorialD.Interpreter.Base
6+import TutorialD.Interpreter.Types
7+import Text.Parsec
8+import Text.Parsec.String
9+import Data.Text
10+import Control.Monad
11+
12+addAtomFunctionExprP :: Parser DatabaseContextIOExpr
13+addAtomFunctionExprP = do
14+ reserved "addatomfunction"
15+ funcName <- liftM pack quotedString
16+ funcType <- atomTypeSignatureP
17+ funcScript <- liftM pack quotedString
18+ pure $ AddAtomFunction funcName funcType funcScript
19+
20+atomTypeSignatureP :: Parser [TypeConstructor]
21+atomTypeSignatureP = sepBy typeConstructorP arrow
22+
23+{-
24+evalDatabaseContextIOOp :: HscEnv -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContextIOExpr)
25+evalDatabaseContextIOOp env context addfunc@(AddAtomFunction _ _ _) = do
26+ evalDatabaseContextIOExpr context
27+ result <- runGhc (Just libdir) $ do
28+ setSession env
29+ ret <- typeCheckAtomFunctionScript script
30+ case ret of
31+ Just err -> pure (Left err)
32+ Nothing -> do
33+ eBody <- compileAtomFunctionScript script
34+ case eBody of
35+ Left err -> pure (Left err)
36+ Right func -> let atomFunc = AtomFunction {
37+ atomFuncName = funcName,
38+ atomFuncType = funcType,
39+ atomFuncBody = AtomFunctionBody (Just script) func } in
40+ --actually add the func
41+ pure $ Right context
42+ case result of
43+ Left err -> Left (AtomFunctionBodyScriptError err)
44+ Right context -> pure (Right context)
45+-}
TutorialD/Interpreter/Export/Base.hs → src/bin/TutorialD/Interpreter/Export/Base.hsrenamed

The content is the same.

TutorialD/Interpreter/Export/CSV.hs → src/bin/TutorialD/Interpreter/Export/CSV.hsrenamed

The content is the same.

TutorialD/Interpreter/Import/Base.hs → src/bin/TutorialD/Interpreter/Import/Base.hsrenamed

The content is the same.

TutorialD/Interpreter/Import/BasicExamples.hs → src/bin/TutorialD/Interpreter/Import/BasicExamples.hsrenamed

The content is the same.

TutorialD/Interpreter/Import/CSV.hs → src/bin/TutorialD/Interpreter/Import/CSV.hsrenamed

The content is the same.

TutorialD/Interpreter/Import/TutorialD.hs → src/bin/TutorialD/Interpreter/Import/TutorialD.hsrenamed

The content is the same.

TutorialD/Interpreter/InformationOperator.hs → src/bin/TutorialD/Interpreter/InformationOperator.hsrenamed

The content is the same.

TutorialD/Interpreter/RODatabaseContextOperator.hs → src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hsrenamed

The content is the same.

TutorialD/Interpreter/RelationalExpr.hs → src/bin/TutorialD/Interpreter/RelationalExpr.hsrenamed

The content is the same.

TutorialD/Interpreter/TransactionGraphOperator.hs → src/bin/TutorialD/Interpreter/TransactionGraphOperator.hsrenamed

The content is the same.

TutorialD/Interpreter/Types.hs → src/bin/TutorialD/Interpreter/Types.hsrenamed

The content is the same.

TutorialD/tutd.hs → src/bin/TutorialD/tutd.hsrenamed

The content is the same.

ProjectM36/Atom.hs → src/lib/ProjectM36/Atom.hsrenamed

The content is the same.

ProjectM36/AtomFunction.hs → src/lib/ProjectM36/AtomFunction.hsrenamed

The content is the same.

ProjectM36/AtomFunctionBody.hs → src/lib/ProjectM36/AtomFunctionBody.hsrenamed+50−31
@@ -6,18 +6,20 @@ import ProjectM36.Error
66
77import Control.Monad.IO.Class
88import Control.Exception
9−import Data.Dynamic
10−import Data.Text
9+import Data.Text hiding (map)
1110
11+import Unsafe.Coerce
1212import GHC
1313import GHC.Paths (libdir)
1414import DynFlags
1515import Outputable hiding ((<>))
1616import PprTyThing
1717import Type hiding (pprTyThing)
18−import TysWiredIn
1918
20−type ScriptSession = HscEnv
19+data ScriptSession = ScriptSession {
20+ hscEnv :: HscEnv,
21+ atomFunctionBodyType :: Type
22+ }
2123
2224-- | Configure a GHC environment/session which we will use for all script compilation.
2325initScriptSession :: IO ScriptSession
@@ -25,11 +27,12 @@ initScriptSession = runGhc (Just libdir) $ do
2527 dflags <- getSessionDynFlags
2628 let dflags' = dflags { hscTarget = HscInterpreted ,
2729 ghcLink = LinkInMemory,
28− safeHaskell = Sf_Safe,
30+ safeHaskell = Sf_Trustworthy,
2931 safeInfer = True,
3032 safeInferred = True,
3133 --trustFlags = [TrustPackage "base"] -- new in 8
32− packageFlags = (packageFlags dflags) ++ [TrustPackage "base"]
34+ packageFlags = (packageFlags dflags) ++ packages,
35+ extraPkgConfs = const [GlobalPkgConf, PkgConfFile "/home/agentm/Dev/project-m36/.cabal-sandbox/x86_64-linux-ghc-7.10.3-packages.conf.d/"] --different in 8
3336 }
3437 `xopt_set` Opt_ExtendedDefaultRules
3538 `xopt_set` Opt_ImplicitPrelude
@@ -37,6 +40,18 @@ initScriptSession = runGhc (Just libdir) $ do
3740 `xopt_set` Opt_ScopedTypeVariables
3841 `gopt_set` Opt_PackageTrust
3942 --`gopt_set` Opt_ImplicitImportQualified
43+ packages = map TrustPackage ["base",
44+ "containers",
45+ "unordered-containers",
46+ "hashable",
47+ "uuid",
48+ "vector",
49+ "text",
50+ "binary",
51+ "vector-binary-instances",
52+ "time",
53+ "project-m36",
54+ "bytestring"] -- package flags changed in 8.0
4055 _ <- setSessionDynFlags dflags'
4156 let safeImportDecl mn = ImportDecl {
4257 ideclSourceSrc = Nothing,
@@ -49,17 +64,27 @@ initScriptSession = runGhc (Just libdir) $ do
4964 ideclAs = Nothing,
5065 ideclHiding = Nothing
5166 }
52−
53− baseTarget <- guessTarget "ProjectM36.ScriptBase" Nothing
54− addTarget baseTarget
55− flag <- load LoadAllTargets
56− case flag of
57− Failed -> error "failed to load"
58− Succeeded -> do
59− setContext [ IIDecl $ safeImportDecl (mkModuleName "Prelude"),
60− IIDecl $ safeImportDecl (mkModuleName "ProjectM36.ScriptBase")]
61− env <- getSession
62− pure env
67+ setContext (map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn))
68+ ["Prelude",
69+ "ProjectM36.Base"])
70+ env <- getSession
71+ fType <- mkAtomFunctionBodyType
72+ pure (ScriptSession env fType)
73+
74+mkAtomFunctionBodyType :: Ghc Type
75+mkAtomFunctionBodyType = do
76+ lBodyName <- parseName "AtomFunctionBodyType"
77+ case lBodyName of
78+ [] -> error "failed to parse AtomFunctionBodyType"
79+ _:_:_ -> error "too many name matches"
80+ bodyName:[] -> do
81+ mThing <- lookupName bodyName
82+ case mThing of
83+ Nothing -> error "failed to find AtomFunctionBodyType"
84+ Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of
85+ Just typ -> pure typ
86+ Nothing -> error "AtomFunctionBodyType is not a type synonym"
87+ Just _ -> error "failed to find type synonym AtomFunctionBodyType"
6388
6489addImport :: String -> Ghc ()
6590addImport moduleNam = do
@@ -70,36 +95,30 @@ showType :: DynFlags -> Type -> String
7095showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
7196
7297-- | Typecheck and validate the
73−typeCheckAtomFunctionScript :: AtomFunctionBodyScript -> Ghc (Maybe AtomFunctionBodyCompilationError)
74−typeCheckAtomFunctionScript inp = do
98+typeCheckAtomFunctionScript :: Type -> AtomFunctionBodyScript -> Ghc (Maybe AtomFunctionBodyCompilationError)
99+typeCheckAtomFunctionScript expectedType inp = do
75100 dflags <- getSessionDynFlags
76101 --catch exception for SyntaxError
77102 funcType <- GHC.exprType (unpack inp)
78103
79− let expectedType = atomFunctionBodyGhcType
80−
81104 if eqType funcType expectedType then
82105 pure Nothing
83106 else
84107 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))
85108
86−atomFunctionBodyGhcType :: Type
87−atomFunctionBodyGhcType = Type.mkFunTy intTy intTy
88−
89109-- | After compiling the script, it must accept a list of Atoms and return an Atom, otherwise an AtomFunctionBodyCompilationError is returned
90−compileAtomFunctionScript :: AtomFunctionBodyScript -> Ghc (Either AtomFunctionBodyCompilationError AtomFunctionBodyType)
91−compileAtomFunctionScript script = do
110+compileAtomFunctionScript :: ScriptSession -> AtomFunctionBodyScript -> Ghc (Either AtomFunctionBodyCompilationError AtomFunctionBodyType)
111+compileAtomFunctionScript (ScriptSession _ funcType) script = do
92112 let sScript = unpack script
93− mErr <- typeCheckAtomFunctionScript script
113+ mErr <- typeCheckAtomFunctionScript funcType script
94114 case mErr of
95115 Just err -> pure (Left err)
96116 Nothing -> do
97117 --catch exception here
98118 --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.
99− mDyn <- fromDynamic <$> dynCompileExpr sScript
100− case mDyn of
101− Nothing -> pure $ Left (TypeCheckCompilationError "" "") --this really shouldn't happen
102− Just funcBody -> pure $ Right funcBody
119+ -- we can't use dynCompileExpr here because
120+ func <- compileExpr sScript
121+ pure $ Right (unsafeCoerce func)
103122
104123catchCompileException :: MonadIO m => IO a -> m (Either AtomFunctionBodyCompilationError a)
105124catchCompileException m = liftIO $ do
ProjectM36/AtomFunctions/Basic.hs → src/lib/ProjectM36/AtomFunctions/Basic.hsrenamed

The content is the same.

ProjectM36/AtomFunctions/Primitive.hs → src/lib/ProjectM36/AtomFunctions/Primitive.hsrenamed

The content is the same.

ProjectM36/AtomType.hs → src/lib/ProjectM36/AtomType.hsrenamed

The content is the same.

ProjectM36/Attribute.hs → src/lib/ProjectM36/Attribute.hsrenamed

The content is the same.

ProjectM36/AttributeNames.hs → src/lib/ProjectM36/AttributeNames.hsrenamed

The content is the same.

ProjectM36/Base.hs → src/lib/ProjectM36/Base.hsrenamed

The content is the same.

ProjectM36/Client.hs → src/lib/ProjectM36/Client.hsrenamed

The content is the same.

ProjectM36/Client/Json.hs → src/lib/ProjectM36/Client/Json.hsrenamed

The content is the same.

ProjectM36/ConcreteTypeRep.hs → src/lib/ProjectM36/ConcreteTypeRep.hsrenamed

The content is the same.

ProjectM36/DataConstructorDef.hs → src/lib/ProjectM36/DataConstructorDef.hsrenamed

The content is the same.

ProjectM36/DataTypes/Basic.hs → src/lib/ProjectM36/DataTypes/Basic.hsrenamed

The content is the same.

ProjectM36/DataTypes/Day.hs → src/lib/ProjectM36/DataTypes/Day.hsrenamed

The content is the same.

ProjectM36/DataTypes/Either.hs → src/lib/ProjectM36/DataTypes/Either.hsrenamed

The content is the same.

ProjectM36/DataTypes/Interval.hs → src/lib/ProjectM36/DataTypes/Interval.hsrenamed

The content is the same.

ProjectM36/DataTypes/Maybe.hs → src/lib/ProjectM36/DataTypes/Maybe.hsrenamed

The content is the same.

ProjectM36/DataTypes/Primitive.hs → src/lib/ProjectM36/DataTypes/Primitive.hsrenamed

The content is the same.

ProjectM36/DatabaseContext.hs → src/lib/ProjectM36/DatabaseContext.hsrenamed

The content is the same.

ProjectM36/DateExamples.hs → src/lib/ProjectM36/DateExamples.hsrenamed

The content is the same.

ProjectM36/Error.hs → src/lib/ProjectM36/Error.hsrenamed

The content is the same.

ProjectM36/Key.hs → src/lib/ProjectM36/Key.hsrenamed

The content is the same.

ProjectM36/MiscUtils.hs → src/lib/ProjectM36/MiscUtils.hsrenamed

The content is the same.

ProjectM36/Notifications.hs → src/lib/ProjectM36/Notifications.hsrenamed

The content is the same.

ProjectM36/Persist.hs → src/lib/ProjectM36/Persist.hsrenamed

The content is the same.

ProjectM36/Relation.hs → src/lib/ProjectM36/Relation.hsrenamed

The content is the same.

ProjectM36/Relation/Parse/CSV.hs → src/lib/ProjectM36/Relation/Parse/CSV.hsrenamed

The content is the same.

ProjectM36/Relation/Show/CSV.hs → src/lib/ProjectM36/Relation/Show/CSV.hsrenamed

The content is the same.

ProjectM36/Relation/Show/Gnuplot.hs → src/lib/ProjectM36/Relation/Show/Gnuplot.hsrenamed

The content is the same.

ProjectM36/Relation/Show/HTML.hs → src/lib/ProjectM36/Relation/Show/HTML.hsrenamed

The content is the same.

ProjectM36/Relation/Show/Term.hs → src/lib/ProjectM36/Relation/Show/Term.hsrenamed

The content is the same.

ProjectM36/RelationalExpression.hs → src/lib/ProjectM36/RelationalExpression.hsrenamed+4−4
@@ -339,13 +339,13 @@ evalContextExpr (RemoveAtomFunction funcName) = do
339339 else
340340 pure (Just (AtomFunctionNameNotInUseError funcName))
341341
342−evalDatabaseContextIOExpr :: HscEnv -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
343−evalDatabaseContextIOExpr hscEnv currentContext (AddAtomFunction funcName funcType script) = do
342+evalDatabaseContextIOExpr :: ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
343+evalDatabaseContextIOExpr scriptSession currentContext (AddAtomFunction funcName funcType script) = do
344344 res <- try $ runGhc (Just libdir) $ do
345− setSession hscEnv
345+ setSession (hscEnv scriptSession)
346346 let atomFuncs = atomFunctions currentContext
347347 --compile the function
348− eCompiledFunc <- compileAtomFunctionScript script
348+ eCompiledFunc <- compileAtomFunctionScript scriptSession script
349349 pure $ case eCompiledFunc of
350350 Left err -> Left (AtomFunctionBodyScriptError err)
351351 Right compiledFunc -> do
ProjectM36/ScriptBase.hs → src/lib/ProjectM36/ScriptBase.hsrenamed

The content is the same.

ProjectM36/Server.hs → src/lib/ProjectM36/Server.hsrenamed

The content is the same.

src/lib/ProjectM36/Server/#WebSocket.hs#new file+89
@@ -0,0 +1,89 @@
1+--module ProjectM36.Server.WebSocket where
2+-- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket
3+-- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs
4+
5+-- launch the project-m36-server
6+-- proxy all connections to it through ProjectM36.Client
7+import Control.Monad (forever)
8+import qualified Data.Text as T
9+import qualified Network.WebSockets as WS
10+import ProjectM36.Server.RemoteCallTypes.Json ()
11+import ProjectM36.Client.Json ()
12+import Data.Aeson
13+import TutorialD.Interpreter
14+import TutorialD.Interpreter.Base
15+import ProjectM36.Client
16+import ProjectM36.Server
17+import ProjectM36.Server.ParseArgs
18+import ProjectM36.Server.Config
19+import Control.Concurrent
20+import Control.Exception
21+
22+-- | Called when the project-m36-server exits.
23+failureHandler :: Either SomeException Bool -> IO ()
24+failureHandler = error "project-m36-server exited unexpectedly"
25+
26+main :: IO ()
27+main = do
28+ -- launch normal project-m36-server
29+ portMVar <- newEmptyMVar
30+ serverConfig <- parseConfig
31+ let serverHost = bindHost serverConfig
32+ _ <- forkFinally (launchServer serverConfig (Just portMVar)) failureHandler
33+ --wait for server to be listening
34+ serverPort <- takeMVar portMVar
35+ --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces
36+ WS.runServer "0.0.0.0" 8888 (websocketProxyServer serverPort serverHost)
37+
38+websocketProxyServer :: Port -> Hostname -> WS.ServerApp
39+websocketProxyServer port host pending = do
40+ conn <- WS.acceptRequest pending
41+ let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)
42+ --phase 1- accept database name for connection
43+ dbmsg <- (WS.receiveData conn) :: IO T.Text
44+ let connectdbmsg = "connectdb:"
45+ if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)
46+ else do
47+ let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg
48+ eDbconn <- createConnection conn dbname port host
49+ case eDbconn of
50+ Left err -> sendError conn err
51+ Right dbconn -> do
52+ eSessionId <- createSessionAtHead "master" dbconn
53+ case eSessionId of
54+ Left err -> sendError conn err
55+ Right sessionId -> do
56+ --phase 2- accept tutoriald commands
57+ _ <- forever $ do
58+ msg <- (WS.receiveData conn) :: IO T.Text
59+ let tutdprefix = "executetutd:"
60+ case msg of
61+ _ | tutdprefix `T.isPrefixOf` msg -> do
62+ let tutdString = T.drop (T.length tutdprefix) msg
63+ case parseTutorialD (T.unpack tutdString) of
64+ Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))
65+ Right parsed -> do
66+ result <- evalTutorialD sessionId dbconn SafeEvaluation parsed
67+ handleOpResult conn dbconn result
68+ _ -> unexpectedMsg
69+ pure ()
70+
71+notificationCallback :: WS.Connection -> NotificationCallback
72+notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,
73+ "evaldnotification" .= evaldNotif
74+ ]))
75+
76+--this creates a new database for each connection- perhaps not what we want (?)
77+createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)
78+createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))
79+
80+sendError :: (ToJSON a) => WS.Connection -> a -> IO ()
81+sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))
82+
83+handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO ()
84+handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db
85+handleOpResult conn _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))
86+handleOpResult _ _ (DisplayIOResult ioout) = ioout
87+handleOpResult conn _ (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))
88+handleOpResult conn _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))
89+handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))
ProjectM36/Server/Config.hs → src/lib/ProjectM36/Server/Config.hsrenamed

The content is the same.

ProjectM36/Server/EntryPoints.hs → src/lib/ProjectM36/Server/EntryPoints.hsrenamed+1−1
@@ -20,7 +20,7 @@ handleExecuteDatabaseContextExpr sessionId conn dbexpr = do
2020
2121handleExecuteDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> Process (ProcessReply (Maybe RelationalError) Connection)
2222handleExecuteDatabaseContextIOExpr sessionId conn dbexpr = do
23− ret <- executeDatabaseContextIOExpr sessionId conn dbexpr
23+ ret <- liftIO $ executeDatabaseContextIOExpr sessionId conn dbexpr
2424 reply ret conn
2525
2626handleExecuteHeadName :: SessionId -> Connection -> Process (ProcessReply (Maybe HeadName) Connection)
src/lib/ProjectM36/Server/EntryPoints/Json.hsnew file

No changes to the content.

ProjectM36/Server/ParseArgs.hs → src/lib/ProjectM36/Server/ParseArgs.hsrenamed

The content is the same.

ProjectM36/Server/RemoteCallTypes.hs → src/lib/ProjectM36/Server/RemoteCallTypes.hsrenamed

The content is the same.

src/lib/ProjectM36/Server/RemoteCallTypes/Json.hsnew file+134
@@ -0,0 +1,134 @@
1+--create a bunch of orphan instances for use with the websocket server
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module ProjectM36.Server.RemoteCallTypes.Json where
4+import ProjectM36.Server.RemoteCallTypes
5+import ProjectM36.Base
6+import ProjectM36.ConcreteTypeRep
7+import ProjectM36.Error
8+import ProjectM36.DataTypes.Primitive
9+
10+import Control.Monad
11+import Data.Aeson
12+import Data.UUID.Aeson ()
13+import Data.ByteString.Base64 as B64
14+import Data.Text.Encoding
15+
16+instance ToJSON RelationalExpr
17+instance FromJSON RelationalExpr
18+
19+instance ToJSON TupleExpr
20+instance FromJSON TupleExpr
21+
22+instance ToJSON RestrictionPredicateExpr
23+instance FromJSON RestrictionPredicateExpr
24+
25+instance ToJSON AtomExpr
26+instance FromJSON AtomExpr
27+
28+instance ToJSON RelationTupleSet
29+instance FromJSON RelationTupleSet
30+
31+instance ToJSON RelationTuple
32+instance FromJSON RelationTuple
33+
34+instance ToJSON ExecuteRelationalExpr
35+instance FromJSON ExecuteRelationalExpr
36+
37+instance ToJSON Relation
38+instance FromJSON Relation
39+
40+instance ToJSON Attribute
41+instance FromJSON Attribute
42+
43+instance ToJSON ExtendTupleExpr
44+instance FromJSON ExtendTupleExpr
45+
46+instance ToJSON AttributeNames
47+instance FromJSON AttributeNames
48+
49+instance ToJSON AttributeExpr
50+instance FromJSON AttributeExpr
51+
52+instance ToJSON AtomType
53+instance FromJSON AtomType
54+
55+instance ToJSON TypeConstructor
56+instance FromJSON TypeConstructor
57+
58+instance ToJSON TypeConstructorArg
59+instance FromJSON TypeConstructorArg
60+
61+instance ToJSON SerialRep
62+instance FromJSON SerialRep
63+
64+instance FromJSON ConcreteTypeRep where
65+ parseJSON = withObject "ctr" $ \o -> do
66+ serialRep <- o .: "serialrep"
67+ pure $ fromSerial serialRep
68+
69+instance ToJSON ConcreteTypeRep where
70+ toJSON ctr = object [
71+ "serialrep" .= toSerial ctr
72+ ]
73+
74+instance ToJSON Atom where
75+ toJSON atom@(IntAtom i) = object [ "type" .= atomTypeForAtom atom,
76+ "val" .= i ]
77+ toJSON atom@(DoubleAtom i) = object [ "type" .= atomTypeForAtom atom,
78+ "val" .= i ]
79+ toJSON atom@(TextAtom i) = object [ "type" .= atomTypeForAtom atom,
80+ "val" .= i ]
81+ toJSON atom@(DayAtom i) = object [ "type" .= atomTypeForAtom atom,
82+ "val" .= i ]
83+ toJSON atom@(DateTimeAtom i) = object [ "type" .= atomTypeForAtom atom,
84+ "val" .= i ]
85+ toJSON atom@(ByteStringAtom i) = object [ "type" .= atomTypeForAtom atom,
86+ "val" .= decodeUtf8 (B64.encode i) ]
87+ toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom,
88+ "val" .= i ]
89+ toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom,
90+ "val" .= i ]
91+ toJSON (ConstructedAtom dConsName atomtype atomlist) = object [
92+ "dataconstructorname" .= dConsName,
93+ "type" .= toJSON atomtype,
94+ "atomlist" .= toJSON atomlist
95+ ]
96+
97+instance FromJSON Atom where
98+ parseJSON = withObject "atom" $ \o -> do
99+ atype <- o .: "type"
100+ case atype of
101+ AnyAtomType -> fail "cannot pass AnyAtomType over the wire"
102+ caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"
103+ RelationAtomType _ -> do
104+ rel <- o .: "val"
105+ pure $ RelationAtom rel
106+ IntAtomType -> IntAtom <$> o .: "val"
107+ DoubleAtomType -> DoubleAtom <$> o .: "val"
108+ TextAtomType -> TextAtom <$> o .: "val"
109+ DayAtomType -> DayAtom <$> o .: "val"
110+ DateTimeAtomType -> DateTimeAtom <$> o .: "val"
111+ ByteStringAtomType -> do
112+ b64bs <- liftM encodeUtf8 (o .: "val")
113+ case B64.decode b64bs of
114+ Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err)
115+ Right bs -> pure (ByteStringAtom bs)
116+ BoolAtomType -> BoolAtom <$> o .: "val"
117+
118+instance ToJSON Notification
119+instance FromJSON Notification
120+
121+instance ToJSON AtomFunctionBodyCompilationError
122+instance FromJSON AtomFunctionBodyCompilationError
123+
124+instance ToJSON RelationalError
125+instance FromJSON RelationalError
126+
127+instance ToJSON MergeError
128+instance FromJSON MergeError
129+
130+instance ToJSON MergeStrategy
131+instance FromJSON MergeStrategy
132+
133+instance ToJSON PersistenceError
134+
ProjectM36/Server/WebSocket.hs → src/lib/ProjectM36/Server/WebSocket.hsrenamed

The content is the same.

ProjectM36/Server/WebSocket/Main.hs → src/lib/ProjectM36/Server/WebSocket/Main.hsrenamed

The content is the same.

ProjectM36/Server/WebSocket/project-m36.js → src/lib/ProjectM36/Server/WebSocket/project-m36.jsrenamed

The content is the same.

ProjectM36/Server/WebSocket/websocket-client.html → src/lib/ProjectM36/Server/WebSocket/websocket-client.htmlrenamed

The content is the same.

ProjectM36/Server/WebSocket/websocket-client.js → src/lib/ProjectM36/Server/WebSocket/websocket-client.jsrenamed

The content is the same.

ProjectM36/Server/project-m36-server.hs → src/lib/ProjectM36/Server/project-m36-server.hsrenamed

The content is the same.

ProjectM36/Session.hs → src/lib/ProjectM36/Session.hsrenamed

The content is the same.

ProjectM36/Sessions.hs → src/lib/ProjectM36/Sessions.hsrenamed

The content is the same.

ProjectM36/StaticOptimizer.hs → src/lib/ProjectM36/StaticOptimizer.hsrenamed

The content is the same.

ProjectM36/Transaction.hs → src/lib/ProjectM36/Transaction.hsrenamed

The content is the same.

ProjectM36/Transaction/Persist.hs → src/lib/ProjectM36/Transaction/Persist.hsrenamed

The content is the same.

ProjectM36/TransactionGraph.hs → src/lib/ProjectM36/TransactionGraph.hsrenamed

The content is the same.

ProjectM36/TransactionGraph/Merge.hs → src/lib/ProjectM36/TransactionGraph/Merge.hsrenamed

The content is the same.

ProjectM36/TransactionGraph/Persist.hs → src/lib/ProjectM36/TransactionGraph/Persist.hsrenamed

The content is the same.

ProjectM36/TransactionGraph/Show.hs → src/lib/ProjectM36/TransactionGraph/Show.hsrenamed

The content is the same.

ProjectM36/TransactionGraph/Show/Dot.hs → src/lib/ProjectM36/TransactionGraph/Show/Dot.hsrenamed

The content is the same.

ProjectM36/Tuple.hs → src/lib/ProjectM36/Tuple.hsrenamed

The content is the same.

ProjectM36/TupleSet.hs → src/lib/ProjectM36/TupleSet.hsrenamed

The content is the same.

ProjectM36/TypeConstructor.hs → src/lib/ProjectM36/TypeConstructor.hsrenamed

The content is the same.

ProjectM36/TypeConstructorDef.hs → src/lib/ProjectM36/TypeConstructorDef.hsrenamed

The content is the same.

src/lib/ProjectM36/WebSocketServer.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module ProjectM36.WebSocketServer where
3+import qualified Network.WebSockets as WS
4+import Control.Monad
5+
6+--add json derivation to RemoteCallTypes
7+runServer :: WS.Connection -> IO ()
8+runServer conn = forever $ handleRequest
9+
10+handleRequest :: WS.Connection -> IO ()
11+handleRequest conn = do
12+ dat <- WS.receiveData conn
13+
14+
ProjectM36/Win32Handle.hs → src/lib/ProjectM36/Win32Handle.hsrenamed

The content is the same.