b27ae9f · project-m36 · git.iko.soy

git.iko.soy/project-m36

fix or squelch all hlint hints in src, examples, test directories

commitb27ae9f3f5f24be212053055e5d19b96ecebcab2 authorAgentM <agentm@themactionfaction.com> dateMon 7 Aug 2017, 19:59 (9 years ago) parent00c9dc7

79 files changed+492−704

compare with master

unifiedsplit

examples/Hospital.hs+5−5

@@ -25,7 +25,7 @@ failFastMaybe :: (Show a) => Maybe a -> IO ()

2525failFastMaybe (Just err) = error (show err)

2626failFastMaybe Nothing = return ()

2727

28−failFastEither :: (Show a) => Either a b -> IO (b)

28+failFastEither :: Show a => Either a b -> IO b

2929failFastEither (Left err) = error (show err)

3030failFastEither (Right val) = return val

3131

@@ -53,11 +53,11 @@ runExample = do

5353 Nothing -> error "not a singleton relation!"

5454 Just tuple -> do

5555 (Atom age_value_out) <- failFastEither $ atomForAttributeName "age" tuple

56− putStrLn (show age_value_in)

57− putStrLn (show age_value_out)

56+ print age_value_in

57+ print age_value_out

5858 case cast age_value_out of

5959 Nothing -> error "wrong datatype"

60− Just age_value_out' -> do

61− putStrLn (show (age_value_in == age_value_out'))

60+ Just age_value_out' ->

61+ print (age_value_in == age_value_out')

6262

6363

examples/SimpleClient.hs+6−6

@@ -9,30 +9,30 @@ main = do

99 -- 2. conncted to the remote database

1010 eConn <- connectProjectM36 connInfo

1111 case eConn of

12− Left err -> putStrLn (show err)

12+ Left err -> print err

1313 Right conn -> do

1414 --3. create a session on the "master" branch

1515 eSessionId <- createSessionAtHead conn "master"

1616 case eSessionId of

17− Left err -> putStrLn (show err)

17+ Left err -> print err

1818 Right sessionId -> do

1919 --4. define a new relation variable with a DatabaseContext expression

2020 let attrList = [Attribute "name" TextAtomType,

2121 Attribute "age" IntAtomType]

2222 attrs = attributesFromList attrList

2323 mErr1 <- executeDatabaseContextExpr sessionId conn (Define "person" (map NakedAttributeExpr attrList))

24− putStrLn (show mErr1)

24+ print mErr1

2525 --5. add a tuple to the relation referenced by the relation variable

2626 let (Right tupSet) = mkTupleSetFromList attrs [[TextAtom "Bob", IntAtom 45]]

2727 mErr2 <- executeDatabaseContextExpr sessionId conn (Insert "person" (MakeStaticRelation attrs tupSet))

28− putStrLn (show mErr2)

28+ print mErr2

2929

3030 --6. execute a relational algebra query

3131 let restrictionPredicate = AttributeEqualityPredicate "name" (NakedAtomExpr (TextAtom "Steve"))

3232 eRel <- executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "person" ()))

3333 case eRel of

34− Left err -> putStrLn (show err)

35− Right rel -> putStrLn (show $ showRelation rel)

34+ Left err -> print err

35+ Right rel -> print (showRelation rel)

3636

3737 --7. close the connection

3838 close conn

examples/out_of_the_tarpit.hs+2−2

@@ -143,8 +143,8 @@ createSchema sessionId conn = do

143143 --gather up and execute all database updates

144144 eErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)

145145 let errs = lefts eErrs

146− when (length errs > 0) (error (show errs))

146+ unless (null errs) (error (show errs))

147147

148148 eErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs

149149 let errs' = lefts eErrs'

150− when (length errs' > 0) (error (show errs'))

150+ unless (null errs') (error (show errs'))

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+3−5

@@ -10,7 +10,6 @@ import ProjectM36.IsomorphicSchema

1010import ProjectM36.DatabaseContextFunctionError

1111import ProjectM36.AtomFunctionError

1212

13−import Control.Monad

1413import Data.Aeson

1514import Data.UUID.Aeson ()

1615import Data.ByteString.Base64 as B64

@@ -72,9 +71,8 @@ instance ToJSON Atom where

7271 "val" .= i ]

7372 toJSON atom@(TextAtom i) = object [ "type" .= atomTypeForAtom atom,

7473 "val" .= i ]

75− toJSON atom@(DayAtom i) = do

76− object [ "type" .= atomTypeForAtom atom,

77− "val" .= toGregorian i ]

74+ toJSON atom@(DayAtom i) = object [ "type" .= atomTypeForAtom atom,

75+ "val" .= toGregorian i ]

7876 toJSON atom@(DateTimeAtom i) = object [ "type" .= atomTypeForAtom atom,

7977 "val" .= i ]

8078 toJSON atom@(ByteStringAtom i) = object [ "type" .= atomTypeForAtom atom,

@@ -106,7 +104,7 @@ instance FromJSON Atom where

106104 pure (DayAtom (fromGregorian y m d))

107105 DateTimeAtomType -> DateTimeAtom <$> o .: "val"

108106 ByteStringAtomType -> do

109− b64bs <- liftM encodeUtf8 (o .: "val")

107+ b64bs <- fmap encodeUtf8 (o .: "val")

110108 case B64.decode b64bs of

111109 Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err)

112110 Right bs -> pure (ByteStringAtom bs)

src/bin/ProjectM36/Server/WebSocket.hs+4−4

@@ -20,7 +20,7 @@ websocketProxyServer port host pending = do

2020 conn <- WS.acceptRequest pending

2121 let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)

2222 --phase 1- accept database name for connection

23− dbmsg <- (WS.receiveData conn) :: IO T.Text

23+ dbmsg <- WS.receiveData conn :: IO T.Text

2424 let connectdbmsg = "connectdb:"

2525 if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)

2626 else do

@@ -28,7 +28,7 @@ websocketProxyServer port host pending = do

2828 bracket (createConnection conn dbname port host)

2929 (\eDBconn -> case eDBconn of

3030 Right dbconn -> close dbconn

31− Left _ -> pure ()) $ \eDBconn -> do

31+ Left _ -> pure ()) $ \eDBconn ->

3232 case eDBconn of

3333 Left err -> sendError conn err

3434 Right dbconn -> do

@@ -42,7 +42,7 @@ websocketProxyServer port host pending = do

4242 --figure out why sending three times during startup is necessary

4343 sendPromptInfo pInfo conn

4444 sendPromptInfo pInfo conn

45− msg <- (WS.receiveData conn) :: IO T.Text

45+ msg <- WS.receiveData conn :: IO T.Text

4646 let tutdprefix = "executetutd:"

4747 case msg of

4848 _ | tutdprefix `T.isPrefixOf` msg -> do

@@ -50,7 +50,7 @@ websocketProxyServer port host pending = do

5050 case parseTutorialD tutdString of

5151 Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))

5252 Right parsed -> do

53− let timeoutFilter = \exc -> if exc == RequestTimeoutException

53+ let timeoutFilter exc = if exc == RequestTimeoutException

5454 then Just exc

5555 else Nothing

5656 responseHandler = do

src/bin/TutorialD/Interpreter.hs+28−29

@@ -25,7 +25,6 @@ import qualified ProjectM36.Client as C

2525import ProjectM36.Relation (attributes)

2626

2727import Text.Megaparsec

28−import Control.Monad.State

2928import System.Console.Haskeline

3029import System.Directory (getHomeDirectory)

3130import qualified Data.Text as T

@@ -55,21 +54,21 @@ data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

5554

5655interpreterParserP :: Parser ParsedOperation

5756interpreterParserP = safeInterpreterParserP <|>

58− liftM ImportRelVarOp (importCSVP <* eof) <|>

59− liftM ImportDBContextOp (tutdImportP <* eof) <|>

60− liftM RelVarExportOp (exportCSVP <* eof) <|>

61− liftM DatabaseContextIOExprOp (dbContextIOExprP <* eof)

57+ fmap ImportRelVarOp (importCSVP <* eof) <|>

58+ fmap ImportDBContextOp (tutdImportP <* eof) <|>

59+ fmap RelVarExportOp (exportCSVP <* eof) <|>

60+ fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof)

6261

6362-- the safe interpreter never reads or writes the file system

6463safeInterpreterParserP :: Parser ParsedOperation

65−safeInterpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>

66− liftM InfoOp (infoOpP <* eof) <|>

67− liftM GraphOp (transactionGraphOpP <* eof) <|>

68− liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>

69− liftM DatabaseContextExprOp (databaseExprOpP <* eof) <|>

70− liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>

71− liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|>

72− liftM SchemaOp (schemaOperatorP <* eof)

64+safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>

65+ fmap InfoOp (infoOpP <* eof) <|>

66+ fmap GraphOp (transactionGraphOpP <* eof) <|>

67+ fmap ROGraphOp (roTransactionGraphOpP <* eof) <|>

68+ fmap DatabaseContextExprOp (databaseExprOpP <* eof) <|>

69+ fmap ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>

70+ fmap TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|>

71+ fmap SchemaOp (schemaOperatorP <* eof)

7372

7473promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType

7574promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "

@@ -77,32 +76,32 @@ promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "

7776 transInfo = either (const "<unknown>") id eHeadName <> "/" <> either (const "<no schema>") id eSchemaName

7877

7978parseTutorialD :: T.Text -> Either (ParseError Char Void) ParsedOperation

80−parseTutorialD inputString = parse interpreterParserP "" inputString

79+parseTutorialD = parse interpreterParserP ""

8180

8281--only parse tutoriald which doesn't result in file I/O

8382safeParseTutorialD :: T.Text -> Either (ParseError Char Void) ParsedOperation

84−safeParseTutorialD inputString = parse safeInterpreterParserP "" inputString

83+safeParseTutorialD = parse safeInterpreterParserP ""

8584

8685data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)

8786

8887--execute the operation and display result

89−evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO (TutorialDOperatorResult)

88+evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult

9089evalTutorialD sessionId conn safe expr = case expr of

9190 --this does not pass through the ProjectM36.Client library because the operations

9291 --are specific to the interpreter, though some operations may be of general use in the future

93− (RODatabaseContextOp execOp) -> do

92+ (RODatabaseContextOp execOp) ->

9493 evalRODatabaseContextOp sessionId conn execOp

9594

96− (DatabaseContextExprOp execOp) -> do

95+ (DatabaseContextExprOp execOp) ->

9796 eHandler $ C.executeDatabaseContextExpr sessionId conn execOp

9897

99− (DatabaseContextIOExprOp execOp) -> do

98+ (DatabaseContextIOExprOp execOp) ->

10099 if needsSafe then

101100 unsafeError

102− else do

101+ else

103102 eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp

104103

105− (GraphOp execOp) -> do

104+ (GraphOp execOp) ->

106105 eHandler $ C.executeGraphExpr sessionId conn execOp

107106

108107 (ROGraphOp execOp) -> do

@@ -111,10 +110,10 @@ evalTutorialD sessionId conn safe expr = case expr of

111110 Left err -> barf err

112111 Right rel -> pure (DisplayRelationResult rel)

113112

114− (SchemaOp execOp) -> do

113+ (SchemaOp execOp) ->

115114 eHandler $ evalSchemaOperator sessionId conn execOp

116115

117− (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do

116+ (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) ->

118117 if needsSafe then

119118 unsafeError

120119 else do

@@ -129,7 +128,7 @@ evalTutorialD sessionId conn safe expr = case expr of

129128 Left err -> barf err

130129 Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)

131130

132− (ImportDBContextOp execOp) -> do

131+ (ImportDBContextOp execOp) ->

133132 if needsSafe then

134133 unsafeError

135134 else do

@@ -138,7 +137,7 @@ evalTutorialD sessionId conn safe expr = case expr of

138137 Left err -> barf err

139138 Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)

140139

141− (InfoOp execOp) -> do

140+ (InfoOp execOp) ->

142141 if needsSafe then

143142 unsafeError

144143 else

@@ -146,7 +145,7 @@ evalTutorialD sessionId conn safe expr = case expr of

146145 Left err -> pure (DisplayErrorResult err)

147146 Right info -> pure (DisplayResult info)

148147

149− (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) -> do

148+ (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) ->

150149 --eval relexpr to relation and pass to export function

151150 if needsSafe then

152151 unsafeError

@@ -162,7 +161,7 @@ evalTutorialD sessionId conn safe expr = case expr of

162161 (ImportBasicExampleOp execOp) -> do

163162 let dbcontextexpr = evalImportBasicExampleOperator execOp

164163 evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)

165− (TransGraphRelationalOp execOp) -> do

164+ (TransGraphRelationalOp execOp) ->

166165 evalTransGraphRelationalOp sessionId conn execOp

167166 where

168167 needsSafe = safe == SafeEvaluation

@@ -200,9 +199,9 @@ reprLoop config sessionId conn = do

200199 Nothing -> return ()

201200 Just line -> do

202201 case parseTutorialD (T.pack line) of

203− Left err -> do

202+ Left err ->

204203 displayOpResult $ DisplayParseErrorResult (T.length prompt) err

205− Right parsed -> do

204+ Right parsed ->

206205 catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do

207206 evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed

208207 displayOpResult evald)

src/bin/TutorialD/Interpreter/Base.hs+6−4

@@ -66,7 +66,7 @@ identifier = do

6666 pure (pack (istart:irest))

6767

6868symbol :: Text -> Parser Text

69−symbol sym = Lex.symbol spaceConsumer sym

69+symbol = Lex.symbol spaceConsumer

7070

7171comma :: Parser Text

7272comma = symbol ","

@@ -100,6 +100,10 @@ float = Lex.float

100100capitalizedIdentifier :: Parser Text

101101capitalizedIdentifier = do

102102 fletter <- upperChar

103+ restOfIdentifier_ fletter

104+

105+restOfIdentifier_ :: Char -> Parser Text

106+restOfIdentifier_ fletter = do

103107 rest <- option "" identifier

104108 spaceConsumer

105109 pure (T.cons fletter rest)

@@ -107,9 +111,7 @@ capitalizedIdentifier = do

107111uncapitalizedIdentifier :: Parser Text

108112uncapitalizedIdentifier = do

109113 fletter <- lowerChar

110− rest <- option "" identifier

111− spaceConsumer

112− pure (T.cons fletter rest)

114+ restOfIdentifier_ fletter

113115

114116showRelationAttributes :: Attributes -> Text

115117showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"

src/bin/TutorialD/Interpreter/DataTypes/DateTime.hs+1−1

@@ -18,5 +18,5 @@ dateTimeStringP :: Parser UTCTime

1818dateTimeStringP = do

1919 dateTimeString <- quotedString

2020 case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack dateTimeString) of

21− Just utctime -> return $ (utctime :: UTCTime)

21+ Just utctime -> pure (utctime :: UTCTime)

2222 Nothing -> fail $ "Failed to parse datetime from " ++ T.unpack dateTimeString

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+2−2

@@ -91,7 +91,7 @@ updateP = do

9191 reservedOp "update"

9292 relVarName <- identifier

9393 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)

94− attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)

94+ attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)

9595 return $ Update relVarName attributeAssignments predicate

9696

9797data IncDepOp = SubsetOp | EqualityOp

@@ -146,7 +146,7 @@ attributeAssignmentP = do

146146 attrName <- identifier

147147 reservedOp ":="

148148 atomExpr <- atomExprP

149− pure $ (attrName, atomExpr)

149+ pure (attrName, atomExpr)

150150

151151addNotificationP :: Parser DatabaseContextExpr

152152addNotificationP = do

src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+10−11

@@ -5,26 +5,25 @@ import ProjectM36.Base

55import TutorialD.Interpreter.Base

66import TutorialD.Interpreter.Types

77import Text.Megaparsec

8+import Data.Text

910addAtomFunctionExprP :: Parser DatabaseContextIOExpr

10−addAtomFunctionExprP = do

11− reserved "addatomfunction"

11+addAtomFunctionExprP = dbioexprP "addatomfunction" AddAtomFunction

12+

13+addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr

14+addDatabaseContextFunctionExprP = dbioexprP "adddatabasecontextfunction" AddDatabaseContextFunction

15+

16+dbioexprP :: Text -> (Text -> [TypeConstructor] -> Text -> DatabaseContextIOExpr) -> Parser DatabaseContextIOExpr

17+dbioexprP res adt = do

18+ reserved res

1219 funcName <- quotedString

1320 funcType <- atomTypeSignatureP

1421 funcScript <- quotedString

15− pure $ AddAtomFunction funcName funcType funcScript

22+ pure $ adt funcName funcType funcScript

1623

1724atomTypeSignatureP :: Parser [TypeConstructor]

1825atomTypeSignatureP = sepBy typeConstructorP arrow

1926

20−addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr

21−addDatabaseContextFunctionExprP = do

22− reserved "adddatabasecontextfunction"

23− funcName <- quotedString

24− funcType <- atomTypeSignatureP

25− funcScript <- quotedString

26− pure $ AddDatabaseContextFunction funcName funcType funcScript

27−

2827dbContextIOExprP :: Parser DatabaseContextIOExpr

2928dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP

3029

src/bin/TutorialD/Interpreter/Export/Base.hs+1−1

@@ -9,5 +9,5 @@ instance Show RelVarDataExportOperator where

99 show (RelVarDataExportOperator expr path _) = "RelVarDataExportOperator " <> show expr <> " " <> path

1010

1111evalRelVarDataExportOperator :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError)

12−evalRelVarDataExportOperator op@(RelVarDataExportOperator _ _ exportFunc) rel = exportFunc op rel

12+evalRelVarDataExportOperator op@(RelVarDataExportOperator _ _ exportFunc) = exportFunc op

1313

src/bin/TutorialD/Interpreter/Export/CSV.hs+1−1

@@ -17,7 +17,7 @@ exportCSVP = do

1717 return $ RelVarDataExportOperator exportExpr (T.unpack path) exportRelationCSV

1818

1919exportRelationCSV :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError)

20−exportRelationCSV (RelVarDataExportOperator _ pathOut _) rel = do

20+exportRelationCSV (RelVarDataExportOperator _ pathOut _) rel =

2121 case relationAsCSV rel of

2222 Left err -> return $ Just err

2323 Right csvData -> do

src/bin/TutorialD/Interpreter/Import/TutorialD.hs+1−1

@@ -16,7 +16,7 @@ importTutorialD pathIn = do

1616 tutdData <- try (TIO.readFile pathIn) :: IO (Either IOError T.Text)

1717 case tutdData of

1818 Left err -> return $ Left (ImportError $ T.pack (show err))

19− Right tutdData' -> do

19+ Right tutdData' ->

2020 case parse multipleDatabaseContextExprP "import" tutdData' of

2121 --parseErrorPretty is new in megaparsec 5

2222 Left err -> pure (Left (PM36E.ParseError (T.pack (show err))))

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+2−2

@@ -97,7 +97,7 @@ evalRODatabaseContextOp sessionId conn (PlotRelation expr) = do

9797 Left err -> DisplayErrorResult $ T.pack (show err)

9898 Right rel -> DisplayIOResult $ do

9999 err <- plotRelation rel

100− when (isJust err) $ putStrLn (show err)

100+ when (isJust err) $ print err

101101

102102evalRODatabaseContextOp sessionId conn (ShowConstraint name) = do

103103 eIncDeps <- C.inclusionDependencies sessionId conn

@@ -130,7 +130,7 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do

130130 Left err -> pure $ DisplayErrorResult (T.pack (show err))

131131 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

132132

133−evalRODatabaseContextOp _ _ (Quit) = pure QuitResult

133+evalRODatabaseContextOp _ _ Quit = pure QuitResult

134134

135135interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO TutorialDOperatorResult

136136interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseContextOperatorP "" tutdstring of

src/bin/TutorialD/Interpreter/RelationalExpr.hs+7−8

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

1010import qualified Data.Set as S

1111import qualified Data.Map as M

1212import Data.List (sort)

13−import Control.Applicative (liftA)

1413import ProjectM36.MiscUtils

1514

1615class RelationalMarkerExpr a where

@@ -30,7 +29,7 @@ attributeListP = do

3029makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

3130makeRelationP = do

3231 reserved "relation"

33− attrExprs <- try (liftA Just makeAttributeExprsP) <|> pure Nothing

32+ attrExprs <- try (fmap Just makeAttributeExprsP) <|> pure Nothing

3433 tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []

3534 pure $ MakeRelationFromExprs attrExprs tupleExprs

3635

@@ -55,7 +54,7 @@ tupleExprP = do

5554 attrAssocs <- braces (sepBy tupleAtomExprP comma)

5655 --detect duplicate attribute names

5756 let dupAttrNames = dupes (sort (map fst attrAssocs))

58− if length dupAttrNames /= 0 then

57+ if not (null dupAttrNames) then

5958 fail ("Attribute names duplicated: " ++ show dupAttrNames)

6059 else

6160 pure (TupleExpr (M.fromList attrAssocs))

@@ -64,7 +63,7 @@ tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase

6463tupleAtomExprP = do

6564 attributeName <- identifier

6665 atomExpr <- atomExprP

67− pure $ (attributeName, atomExpr)

66+ pure (attributeName, atomExpr)

6867

6968projectP :: Parser (RelationalExprBase a -> RelationalExprBase a)

7069projectP = do

@@ -76,7 +75,7 @@ renameClauseP = do

7675 oldAttr <- identifier

7776 reservedOp "as"

7877 newAttr <- identifier

79− pure $ (oldAttr, newAttr)

78+ pure (oldAttr, newAttr)

8079

8180renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)

8281renameP = do

@@ -84,7 +83,7 @@ renameP = do

8483 renameList <- braces (sepBy renameClauseP comma)

8584 case renameList of

8685 [] -> pure (Restrict TruePredicate) --no-op when rename list is empty

87− renames -> do

86+ renames ->

8887 pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames

8988

9089whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

@@ -95,7 +94,7 @@ groupClauseP = do

9594 attrs <- braces attributeListP

9695 reservedOp "as"

9796 newAttrName <- identifier

98− return $ (attrs, newAttrName)

97+ pure (attrs, newAttrName)

9998

10099groupP :: Parser (RelationalExprBase a -> RelationalExprBase a)

101100groupP = do

@@ -232,7 +231,7 @@ relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

232231relationalAtomExprP = RelationAtomExpr <$> relExprP

233232

234233stringAtomP :: Parser Atom

235−stringAtomP = liftA TextAtom quotedString

234+stringAtomP = TextAtom <$> quotedString

236235

237236doubleAtomP :: Parser Atom

238237doubleAtomP = DoubleAtom <$> float

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+2−2

@@ -16,8 +16,8 @@ import qualified Data.Text as T

1616instance RelationalMarkerExpr TransactionIdLookup where

1717 parseMarkerP = string "@" *> transactionIdLookupP

1818

19−data TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr

20− deriving Show

19+newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr

20+ deriving Show

2121

2222transactionIdLookupP :: Parser TransactionIdLookup

2323transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|>

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+3−3

@@ -38,12 +38,12 @@ commitTransactionP = do

3838rollbackTransactionP :: Parser TransactionGraphOperator

3939rollbackTransactionP = do

4040 reservedOp ":rollback"

41− return $ Rollback

41+ return Rollback

4242

4343showGraphP :: Parser ROTransactionGraphOperator

4444showGraphP = do

4545 reservedOp ":showgraph"

46− return $ ShowGraph

46+ return ShowGraph

4747

4848mergeTransactionStrategyP :: Parser MergeStrategy

4949mergeTransactionStrategyP = (reserved "union" *> pure UnionMergeStrategy) <|>

@@ -65,7 +65,7 @@ mergeTransactionsP = do

6565 pure (MergeTransactions strategy headA headB)

6666

6767transactionGraphOpP :: Parser TransactionGraphOperator

68−transactionGraphOpP = do

68+transactionGraphOpP =

6969 jumpToHeadP

7070 <|> jumpToTransactionP

7171 <|> branchTransactionP

src/bin/TutorialD/tutd.hs+1−1

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

8787 let connInfo = connectionInfoForConfig interpreterConfig

8888 dbconn <- connectProjectM36 connInfo

8989 case dbconn of

90− Left err -> do

90+ Left err ->

9191 errDie ("Failed to create database connection: " ++ show err)

9292 Right conn -> do

9393 let connHeadName = headNameForConfig interpreterConfig

src/bin/benchmark/Relation.hs+1−1

@@ -12,7 +12,7 @@ matrixRelation :: Int -> Int -> Either RelationalError Relation

1212matrixRelation attributeCount tupleCount = do

1313 let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]

1414 tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))

15− tuples = map (\c -> tuple c) [0 .. tupleCount]

15+ tuples = map tuple [0 .. tupleCount]

1616 mkRelationDeferVerify attrs (RelationTupleSet tuples)

1717

1818main :: IO ()

src/bin/benchmark/bigrel.hs+8−8

@@ -26,7 +26,7 @@ import Data.Monoid

2626

2727dumpcsv :: Relation -> IO ()

2828dumpcsv rel = case relationAsCSV rel of

29− Left err -> hPutStrLn stderr (show err)

29+ Left err -> hPrint stderr err

3030 Right bsData -> BS.putStrLn bsData

3131

3232data BigrelArgs = BigrelArgs Int Int Text

@@ -52,9 +52,9 @@ main = do

5252 --intmapMatrixRun

5353

5454matrixRun :: BigrelArgs -> IO ()

55−matrixRun (BigrelArgs attributeCount tupleCount tutd) = do

55+matrixRun (BigrelArgs attributeCount tupleCount tutd) =

5656 case matrixRelation attributeCount tupleCount of

57− Left err -> putStrLn (show err)

57+ Left err -> print err

5858 Right rel -> if tutd == "" then

5959 putStrLn "Done."

6060 else do

@@ -64,14 +64,14 @@ matrixRun (BigrelArgs attributeCount tupleCount tutd) = do

6464 --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd

6565 --displayOpResult plan

6666 case interpreted of

67− Right context' -> TIO.putStrLn $ relationAsHTML ((relationVariables context') M.! "x")

68− Left err -> hPutStrLn stderr (show err)

67+ Right context' -> TIO.putStrLn $ relationAsHTML (relationVariables context' M.! "x")

68+ Left err -> hPrint stderr err

6969

7070

7171intmapMatrixRun :: IO ()

7272intmapMatrixRun = do

7373 let matrix = intmapMatrixRelation 100 100000

74− putStrLn (show matrix)

74+ print matrix

7575

7676--compare IntMap speed and size

7777--this is about 3 times faster (9 minutes) for 10x100000 and uses 800 MB

@@ -86,7 +86,7 @@ instance Hash.Hashable (IM.IntMap Atom) where

8686vectorMatrixRun :: IO ()

8787vectorMatrixRun = do

8888 let matrix = vectorMatrixRelation 100 100000

89− putStrLn (show matrix)

89+ print matrix

9090

9191-- 20 s 90 MBs- a clear win- ideal size is 10 * 100000 * 8 bytes = 80 MB! without IntAtom wrapper

9292--with IntAtom wrapper: 1m12s 90 MB

@@ -104,6 +104,6 @@ matrixRelation :: Int -> Int -> Either RelationalError Relation

104104matrixRelation attributeCount tupleCount = do

105105 let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]

106106 tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))

107− tuples = map (\c -> tuple c) [0 .. tupleCount]

107+ tuples = map tuple [0 .. tupleCount]

108108 mkRelationDeferVerify attrs (RelationTupleSet tuples)

109109

src/lib/ProjectM36/AtomFunction.hs+7−6

@@ -42,11 +42,12 @@ extractAtomFunctionType typeIn = do

4242 --expected atom ret value - used to make funcType

4343 lastArg = take 1 (reverse typeIn)

4444 case lastArg of

45− (ADTypeConstructor "Either"

46− ((ADTypeConstructor "AtomFunctionError" []):

47− atomRetArg:[])):[] -> do

45+ [ADTypeConstructor "Either"

46+ [ADTypeConstructor "AtomFunctionError" [],

47+ atomRetArg]] ->

4848 pure (atomArgs ++ [atomRetArg])

49− otherType -> Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))

49+ otherType ->

50+ Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))

5051

5152isScriptedAtomFunction :: AtomFunction -> Bool

5253isScriptedAtomFunction func = case atomFuncBody func of

@@ -59,8 +60,8 @@ atomFunctionScript func = case atomFuncBody func of

5960

6061-- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime.

6162createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr

62−createScriptedAtomFunction funcName argsType retType script = AddAtomFunction funcName (

63+createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName (

6364 argsType ++ [ADTypeConstructor "Either" [

6465 ADTypeConstructor "AtomFunctionError" [],

65− retType]]) script

66+ retType]])

6667

src/lib/ProjectM36/AtomFunctionBody.hs+1−1

@@ -4,4 +4,4 @@ module ProjectM36.AtomFunctionBody where

44import ProjectM36.Base

66compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody

7−compiledAtomFunctionBody func = AtomFunctionBody Nothing func

7+compiledAtomFunctionBody = AtomFunctionBody Nothing

src/lib/ProjectM36/AtomFunctions/Primitive.hs+13−12

@@ -8,13 +8,14 @@ import qualified Data.HashSet as HS

88import qualified Data.Vector as V

99import qualified Data.ByteString.Base64 as B64

1010import qualified Data.Text.Encoding as TE

11+import Control.Monad

1112

1213primitiveAtomFunctions :: AtomFunctions

1314primitiveAtomFunctions = HS.fromList [

1415 --match on any relation type

1516 AtomFunction { atomFuncName = "add",

1617 atomFuncType = [IntAtomType, IntAtomType, IntAtomType],

17− atomFuncBody = body (\((IntAtom i1):(IntAtom i2):_) -> pure (IntAtom (i1 + i2)))},

18+ atomFuncBody = body (\(IntAtom i1:IntAtom i2:_) -> pure (IntAtom (i1 + i2)))},

1819 AtomFunction { atomFuncName = "id",

1920 atomFuncType = [TypeVariableType "a", TypeVariableType "a"],

2021 atomFuncBody = body (\(x:_) -> pure x)},

@@ -23,13 +24,13 @@ primitiveAtomFunctions = HS.fromList [

2324 atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)},

2425 AtomFunction { atomFuncName = "count",

2526 atomFuncType = foldAtomFuncType (TypeVariableType "a") IntAtomType,

26− atomFuncBody = body (\((RelationAtom relIn):_) -> relationCount relIn)},

27+ atomFuncBody = body (\(RelationAtom relIn:_) -> relationCount relIn)},

2728 AtomFunction { atomFuncName = "max",

2829 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

29− atomFuncBody = body (\((RelationAtom relIn):_) -> relationMax relIn)},

30+ atomFuncBody = body (\(RelationAtom relIn:_) -> relationMax relIn)},

3031 AtomFunction { atomFuncName = "min",

3132 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

32− atomFuncBody = body (\((RelationAtom relIn):_) -> relationMin relIn)},

33+ atomFuncBody = body (\(RelationAtom relIn:_) -> relationMin relIn)},

3334 AtomFunction { atomFuncName = "lt",

3435 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

3536 atomFuncBody = body $ intAtomFuncLessThan False},

@@ -38,16 +39,16 @@ primitiveAtomFunctions = HS.fromList [

3839 atomFuncBody = body $ intAtomFuncLessThan True},

3940 AtomFunction { atomFuncName = "gte",

4041 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

41− atomFuncBody = body $ \args -> intAtomFuncLessThan False args >>= boolAtomNot},

42+ atomFuncBody = body $ intAtomFuncLessThan False >=> boolAtomNot},

4243 AtomFunction { atomFuncName = "gt",

4344 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

44− atomFuncBody = body $ \args -> intAtomFuncLessThan True args >>= boolAtomNot},

45+ atomFuncBody = body $ intAtomFuncLessThan True >=> boolAtomNot},

4546 AtomFunction { atomFuncName = "not",

4647 atomFuncType = [BoolAtomType, BoolAtomType],

4748 atomFuncBody = body $ \(b:_) -> boolAtomNot b },

4849 AtomFunction { atomFuncName = "makeByteString",

4950 atomFuncType = [TextAtomType, ByteStringAtomType],

50− atomFuncBody = body $ \((TextAtom textIn):_) -> case B64.decode (TE.encodeUtf8 textIn) of

51+ atomFuncBody = body $ \(TextAtom textIn:_) -> case B64.decode (TE.encodeUtf8 textIn) of

5152 Left err -> Left (AtomFunctionBytesDecodingError err)

5253 Right bs -> pure (ByteStringAtom bs) }

5354 ]

@@ -55,7 +56,7 @@ primitiveAtomFunctions = HS.fromList [

5556 body = AtomFunctionBody Nothing

5657

5758intAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom

58−intAtomFuncLessThan equality ((IntAtom i1):(IntAtom i2):_) = pure (BoolAtom (i1 `op` i2))

59+intAtomFuncLessThan equality (IntAtom i1:IntAtom i2:_) = pure (BoolAtom (i1 `op` i2))

5960 where

6061 op = if equality then (<=) else (<)

6162intAtomFuncLessThan _ _= pure (BoolAtom False)

@@ -66,11 +67,11 @@ boolAtomNot _ = error "boolAtomNot called on non-Bool atom"

6667

6768--used by sum atom function

6869relationSum :: Relation -> Either AtomFunctionError Atom

69−relationSum relIn = pure (IntAtom (relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn))

70+relationSum relIn = pure (IntAtom (relFold (\tupIn acc -> acc + newVal tupIn) 0 relIn))

7071 where

7172 --extract Int from Atom

7273 newVal :: RelationTuple -> Int

73− newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)

74+ newVal tupIn = castInt (tupleAtoms tupIn V.! 0)

7475

7576relationCount :: Relation -> Either AtomFunctionError Atom

7677relationCount relIn = pure (IntAtom (relFold (\_ acc -> acc + 1) (0::Int) relIn))

@@ -78,12 +79,12 @@ relationCount relIn = pure (IntAtom (relFold (\_ acc -> acc + 1) (0::Int) relIn)

7879relationMax :: Relation -> Either AtomFunctionError Atom

7980relationMax relIn = pure (IntAtom (relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn))

8081 where

81− newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)

82+ newVal tupIn = castInt (tupleAtoms tupIn V.! 0)

8283

8384relationMin :: Relation -> Either AtomFunctionError Atom

8485relationMin relIn = pure (IntAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn))

8586 where

86− newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)

87+ newVal tupIn = castInt (tupleAtoms tupIn V.! 0)

8788

8889castInt :: Atom -> Int

8990castInt (IntAtom i) = i

src/lib/ProjectM36/AtomType.hs+15−17

@@ -17,7 +17,7 @@ import qualified Data.Map as M

1717import qualified Data.Text as T

1818

1919findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)

20−findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

20+findDataConstructor dName = foldr tConsFolder Nothing

2121 where

2222 tConsFolder (tCons, dConsList) accum = if isJust accum then

2323 accum

@@ -34,7 +34,7 @@ findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList

3434-- Used in typeFromAtomExpr to validate argument types.

3535atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructorMapping -> Either RelationalError AtomType

3636-- search for the data constructor and resolve the types' names

37−atomTypeForDataConstructorName dConsName atomTypesIn tConsList = do

37+atomTypeForDataConstructorName dConsName atomTypesIn tConsList =

3838 case findDataConstructor dConsName tConsList of

3939 Nothing -> Left (NoSuchDataConstructorError dConsName)

4040 Just (tCons, dCons) -> do

@@ -61,7 +61,7 @@ isValidAtomTypeForTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorR

6161-- | Used to determine if the atom arguments can be used with the data constructor.

6262-- | This is the entry point for type-checking from RelationalExpression.hs.

6363atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType

64−atomTypeForDataConstructor tConss dConsName atomArgTypes = do

64+atomTypeForDataConstructor tConss dConsName atomArgTypes =

6565 --lookup the data constructor

6666 case findDataConstructor dConsName tConss of

6767 Nothing -> Left (NoSuchDataConstructorError dConsName)

@@ -135,13 +135,13 @@ atomTypeForTypeConstructor (TypeVariable tvname) _ = Right (TypeVariableType tvn

135135atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of

136136 Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))

137137 Just (tConsDef, _) -> do

138− tConsArgTypes <- mapM ((flip atomTypeForTypeConstructor) tConss) (TC.arguments tCons)

138+ tConsArgTypes <- mapM (`atomTypeForTypeConstructor` tConss) (TC.arguments tCons)

139139 let pVarNames = TCD.typeVars tConsDef

140140 tConsArgs = M.fromList (zip pVarNames tConsArgTypes)

141141 Right (ConstructedAtomType (TC.name tCons) tConsArgs)

142142

143143findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])

144−findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList

144+findTypeConstructor name = foldr tConsFolder Nothing

145145 where

146146 tConsFolder (tCons, dConsList) accum = if TCD.name tCons == name then

147147 Just (tCons, dConsList)

@@ -170,7 +170,7 @@ resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

170170 Nothing -> Left (TypeConstructorTypeVarMissing key)

171171 Just val -> Right val

172172 -}

173− let resolveTypePair resKey resType = do

173+ let resolveTypePair resKey resType =

174174 -- if the key is missing in the unresolved type map, then fill it in with the value from the resolved map

175175 case M.lookup resKey unresolvedTypeMap of

176176 Just unresType -> case unresType of

@@ -179,7 +179,7 @@ resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do

179179 resSubType <- resolveAtomType resType subType

180180 pure (resKey, resSubType)

181181 otherType -> pure (resKey, otherType)

182− Nothing -> do

182+ Nothing ->

183183 pure (resKey, resType) --swipe the missing type var from the expected map

184184 tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap)

185185 pure (M.fromList tVarList)

@@ -195,12 +195,12 @@ resolveTypeInAtom _ atom = Right atom

195195-- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system.

196196resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

197197resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do

198− newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ (map A.atomType (V.toList resolvedAttrs)))

198+ newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ map A.atomType (V.toList resolvedAttrs))

199199 Right (RelationTuple resolvedAttrs (V.fromList newAtoms))

200200

201201-- | Validate that the type is provided with complete type variables for type constructors.

202202validateAtomType :: AtomType -> TypeConstructorMapping -> Either RelationalError ()

203−validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do

203+validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss =

204204 case findTypeConstructor tConsName tConss of

205205 Nothing -> Left (TypeConstructorAtomTypeMismatch tConsName typ)

206206 Just (tConsDef, _) -> case tConsDef of

@@ -221,13 +221,11 @@ validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (at

221221atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

222222atomTypeVerify (TypeVariableType _) x = Right x

223223atomTypeVerify x (TypeVariableType _) = Right x

224−atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB) =

225− if tConsNameA /= tConsNameB then

226− Left (TypeConstructorNameMismatch tConsNameA tConsNameB)

227− else if not (typeVarMapsVerify tVarMapA tVarMapB) then

228− Left (TypeConstructorTypeVarsTypesMismatch tConsNameA tVarMapA tVarMapB)

229− else

230− Right x

224+atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB)

225+ | tConsNameA /= tConsNameB = Left (TypeConstructorNameMismatch tConsNameA tConsNameB)

226+ | not (typeVarMapsVerify tVarMapA tVarMapB) = Left (TypeConstructorTypeVarsTypesMismatch tConsNameA tVarMapA tVarMapB)

227+ | otherwise = Right x

228+

231229atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

232230 _ <- mapM (\(attr1,attr2) -> let name1 = A.attributeName attr1

233231 name2 = A.attributeName attr2 in

@@ -260,7 +258,7 @@ prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAto

260258

261259resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap

262260resolveTypeVariables expectedArgTypes actualArgTypes = do

263− let tvmaps = map (uncurry resolveTypeVariable) (zip expectedArgTypes actualArgTypes)

261+ let tvmaps = zipWith resolveTypeVariable expectedArgTypes actualArgTypes

264262 --if there are any new keys which don't have equal values then we have a conflict!

265263 foldM (\acc tvmap -> do

266264 let inter = M.intersectionWithKey (\tvName vala valb ->

src/lib/ProjectM36/Atomable.hs+10−11

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, DeriveGeneric, DeriveAnyClass #-}

1+{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts #-}

22module 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

@@ -15,6 +15,7 @@ import Control.Applicative

1515import Data.Time.Calendar

1616import Data.ByteString (ByteString)

1717import Data.Time.Clock

18+import Data.Maybe

1819

1920--also add haskell scripting atomable support

2021--rename this module to Atomable along with test

@@ -54,35 +55,35 @@ class (Eq a, NFData a, Binary a, Show a) => Atomable a where

5455 toDatabaseContextExpr v = toDatabaseContextExprG (from v) (toAtomType v)

5556

5657instance Atomable Int where

57− toAtom i = IntAtom i

58+ toAtom = IntAtom

5859 fromAtom (IntAtom i) = i

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

6061 toAtomType _ = IntAtomType

6162 toDatabaseContextExpr _ = NoOperation

6263

6364instance Atomable Double where

64− toAtom d = DoubleAtom d

65+ toAtom = DoubleAtom

6566 fromAtom (DoubleAtom d) = d

6667 fromAtom _ = error "improper fromAtom"

6768 toAtomType _ = DoubleAtomType

6869 toDatabaseContextExpr _ = NoOperation

6970

7071instance Atomable T.Text where

71− toAtom t = TextAtom t

72+ toAtom = TextAtom

7273 fromAtom (TextAtom t) = t

7374 fromAtom _ = error "improper fromAtom"

7475 toAtomType _ = TextAtomType

7576 toDatabaseContextExpr _ = NoOperation

7677

7778instance Atomable Day where

78− toAtom d = DayAtom d

79+ toAtom = DayAtom

7980 fromAtom (DayAtom d) = d

8081 fromAtom _ = error "improper fromAtom"

8182 toAtomType _ = DayAtomType

8283 toDatabaseContextExpr _ = NoOperation

8384

8485instance Atomable UTCTime where

85− toAtom t = DateTimeAtom t

86+ toAtom = DateTimeAtom

8687 fromAtom (DateTimeAtom t) = t

8788 fromAtom _ = error "improper fromAtom"

8889 toAtomType _ = DateTimeAtomType

@@ -135,7 +136,7 @@ class AtomableG g where

135136

136137--data type metadata

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

138− toAtomG (M1 v) t = toAtomG v t

139+ toAtomG (M1 v) = toAtomG v

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

140141 toAtomsG = undefined

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

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

196197 where

197198 tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType

198199 primitiveAType = toAtomType v

199− primitiveATypeName = case foldr (\((PrimitiveTypeConstructorDef name typ), _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping of

200− Just x -> x

201− Nothing -> error ("primitive type missing: " ++ show primitiveAType)

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

202201

203202instance AtomableG U1 where

204203 toAtomG = undefined

@@ -212,7 +211,7 @@ instance AtomableG U1 where

212211-- product types

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

214213 toAtomG = undefined

215− fromAtomG atom args = (:*:) <$> (fromAtomG atom [headatom args]) <*> (fromAtomG atom (tailatoms args))

214+ fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args)

216215 where headatom (x:_) = x

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

218217 tailatoms (_:xs) = xs

src/lib/ProjectM36/Attribute.hs+9−12

@@ -27,7 +27,7 @@ atomType :: Attribute -> AtomType

2727atomType (Attribute _ atype) = atype

2828

2929atomTypes :: Attributes -> V.Vector AtomType

30−atomTypes attrs = V.map atomType attrs

30+atomTypes = V.map atomType

3131

3232--hm- no error-checking here

3333addAttribute :: Attribute -> Attributes -> Attributes

@@ -35,17 +35,14 @@ addAttribute attr attrs = attrs `V.snoc` attr

3535

3636--if some attribute names overlap but the types do not, then spit back an error

3737joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

38−joinAttributes attrs1 attrs2 = if V.length uniqueOverlappingAttributes /= V.length overlappingAttributes then

39− Left (TupleAttributeTypeMismatchError overlappingAttributes)

40− else if V.length overlappingAttrsDifferentTypes > 0 then

41− Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)

42− else

43− Right $ vectorUniqueify (attrs1 V.++ attrs2)

38+joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)

39+ | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)

40+ | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)

4441 where

4542 overlappingAttrsDifferentTypes = V.filter (\attr -> V.elem (attributeName attr) attrNames2 && V.notElem attr attrs2) attrs1

4643 attrNames2 = V.map attributeName attrs2

4744 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes

48− overlappingAttributes = V.filter (\attr -> V.elem attr attrs2) attrs1

45+ overlappingAttributes = V.filter (`V.elem` attrs2) attrs1

4946

5047addAttributes :: Attributes -> Attributes -> Attributes

5148addAttributes = (V.++)

@@ -57,7 +54,7 @@ renameAttribute :: AttributeName -> Attribute -> Attribute

5754renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo

5855

5956renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes

60−renameAttributes oldAttrName newAttrName attrs = V.map renamer attrs

57+renameAttributes oldAttrName newAttrName = V.map renamer

6158 where

6259 renamer attr = if attributeName attr == oldAttrName then

6360 renameAttribute newAttrName attr

@@ -75,7 +72,7 @@ attributeForName attrName attrs = case V.find (\attr -> attributeName attr == at

7572 Just attr -> Right attr

7673

7774attributesForNames :: S.Set AttributeName -> Attributes -> Attributes

78−attributesForNames attrNameSet attrs = V.filter filt attrs

75+attributesForNames attrNameSet = V.filter filt

7976 where

8077 filt attr = S.member (attributeName attr) attrNameSet

8178

@@ -90,7 +87,7 @@ attributesContained :: Attributes -> Attributes -> Bool

9087attributesContained attrs1 attrs2 = attributeNamesContained (attributeNameSet attrs1) (attributeNameSet attrs2)

9188

9289attributeNamesContained :: S.Set AttributeName -> S.Set AttributeName -> Bool

93−attributeNamesContained attrs1 attrs2 = S.isSubsetOf attrs1 attrs2

90+attributeNamesContained = S.isSubsetOf

9491

9592--returns the disjunction of the AttributeNameSets

9693nonMatchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName

@@ -100,7 +97,7 @@ matchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set

10097matchingAttributeNameSet = S.intersection

10198

10299attributeNamesNotContained :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName

103−attributeNamesNotContained subset superset = S.filter (flip S.notMember superset) subset

100+attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) subset

104101

105102-- this is sorted so the tuples know in which order to output- the ordering is arbitrary

106103sortedAttributeNameList :: S.Set AttributeName -> [AttributeName]

src/lib/ProjectM36/Base.hs+8−8

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ExistentialQuantification,BangPatterns,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

33module ProjectM36.Base where

44import ProjectM36.DatabaseContextFunctionError

@@ -106,7 +106,7 @@ attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2

106106 attrsAsSet = HS.fromList . V.toList

107107

108108sortedAttributesIndices :: Attributes -> [(Int, Attribute)]

109−sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)

109+sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)

110110

111111-- | The relation's tuple set is the body of the relation.

112112newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)

@@ -130,7 +130,7 @@ instance Hashable RelationTuple where

130130 else

131131 salt `hashWithSalt`

132132 sortedAttrs `hashWithSalt`

133− (V.toList sortedTupVec)

133+ V.toList sortedTupVec

134134 where

135135 sortedAttrsIndices = sortedAttributesIndices attrs

136136 sortedAttrs = map snd sortedAttrsIndices

@@ -264,7 +264,7 @@ data Schemas = Schemas DatabaseContext Subschemas

264264

265265-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.

266266-- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context.

267−data Schema = Schema SchemaIsomorphs

267+newtype Schema = Schema SchemaIsomorphs

268268 deriving (Generic, Binary)

269269

270270data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) |

@@ -440,7 +440,7 @@ data AtomFunction = AtomFunction {

440440 } deriving (Generic, NFData)

441441

442442instance Hashable AtomFunction where

443− hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)

443+ hashWithSalt salt func = salt `hashWithSalt` atomFuncName func

444444

445445instance Eq AtomFunction where

446446 f1 == f2 = atomFuncName f1 == atomFuncName f2

@@ -449,7 +449,7 @@ instance Show AtomFunction where

449449 show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes ++ "; " ++ body

450450 where

451451 body = show (atomFuncBody aFunc)

452− showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

452+ showArgTypes = L.intercalate "->" (map show (atomFuncType aFunc))

453453

454454-- | The 'AttributeNames' structure represents a set of attribute names or the same set of names but inverted in the context of a relational expression. For example, if a relational expression has attributes named "a", "b", and "c", the 'InvertedAttributeNames' of ("a","c") is ("b").

455455data AttributeNames = AttributeNames (S.Set AttributeName) |

@@ -472,7 +472,7 @@ data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructo

472472 deriving (Eq, Show, Generic, Binary, NFData)

473473

474474-- | Dynamically create a tuple from attribute names and 'AtomExpr's.

475−data TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

475+newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

476476 deriving (Eq, Show, Generic, NFData)

477477

478478instance Binary TupleExpr

@@ -508,7 +508,7 @@ data DatabaseContextFunction = DatabaseContextFunction {

508508type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction

509509

510510instance Hashable DatabaseContextFunction where

511− hashWithSalt salt func = salt `hashWithSalt` (dbcFuncName func)

511+ hashWithSalt salt func = salt `hashWithSalt` dbcFuncName func

512512

513513instance Eq DatabaseContextFunction where

514514 f1 == f2 = dbcFuncName f1 == dbcFuncName f2

src/lib/ProjectM36/Client.hs+27−34

@@ -126,12 +126,10 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPo

126126import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess, closeLocalNode)

127127import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

128128import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)

129−import Control.Distributed.Process (NodeId(..), reconnect)

130−

131129import Data.Either (isRight)

132130import Data.UUID.V4 (nextRandom)

133131import Data.Word

134−import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match)

132+import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match, NodeId(..), reconnect)

135133import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception)

136134import Control.Concurrent.MVar

137135import qualified Data.Map as M

@@ -179,7 +177,7 @@ data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCa

179177type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification

180178

181179-- | Used for callbacks from the server when monitored changes have been made.

182−data NotificationMessage = NotificationMessage EvaluatedNotifications

180+newtype NotificationMessage = NotificationMessage EvaluatedNotifications

183181 deriving (Binary, Eq, Show, Generic)

184182

185183-- | When a notification is fired, the 'reportExpr' is evaluated in the commit's context, so that is returned along with the original notification.

@@ -259,9 +257,9 @@ notificationListener :: NotificationCallback -> Process ()

259257notificationListener callback = do

260258 --pid <- getSelfPid

261259 --liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid

262− _ <- forever $ do

260+ _ <- forever $

263261 receiveWait [

264− match (\(NotificationMessage eNots) -> do

262+ match (\(NotificationMessage eNots) ->

265263 --say $ "NOTIFICATION: " ++ show eNots

266264 -- when notifications are thrown, they are not adjusted for the current schema which could be problematic, but we don't have access to the current session here

267265 liftIO $ mapM_ (uncurry callback) (M.toList eNots)

@@ -270,14 +268,14 @@ notificationListener callback = do

270268 --say "LISTENER THREAD EXIT"

271269 pure ()

272270

273−startNotificationListener :: LocalNode -> NotificationCallback -> IO (ProcessId)

271+startNotificationListener :: LocalNode -> NotificationCallback -> IO ProcessId

274272startNotificationListener localNode callback = forkProcess localNode (notificationListener callback)

275273

276274createScriptSession :: [String] -> IO (Maybe ScriptSession)

277275createScriptSession ghcPkgPaths = do

278276 eScriptSession <- initScriptSession ghcPkgPaths

279277 case eScriptSession of

280− Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ (show err)) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

278+ Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

281279 Right s -> pure (Just s)

282280

283281-- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'.

@@ -297,7 +295,7 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPath

297295 notificationPid <- startNotificationListener localNode notificationCallback

298296 mScriptSession <- createScriptSession ghcPkgPaths

299297

300− let conn = InProcessConnection (InProcessConnectionConf {

298+ let conn = InProcessConnection InProcessConnectionConf {

301299 ipPersistenceStrategy = strat,

302300 ipClientNodes = clientNodes,

303301 ipSessions = sessions,

@@ -305,7 +303,7 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPath

305303 ipScriptSession = mScriptSession,

306304 ipLocalNode = localNode,

307305 ipTransport = transport,

308− ipLocks = Nothing})

306+ ipLocks = Nothing}

309307 addClientNode conn notificationPid

310308 pure (Right conn)

311309 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

@@ -326,8 +324,8 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notific

326324 loginConfirmation <- safeLogin (Login notificationListenerPid) serverProcessId

327325 if not loginConfirmation then

328326 liftIO $ putMVar connStatus (Left LoginError)

329− else do

330− liftIO $ putMVar connStatus (Right $ RemoteProcessConnection (RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport}))

327+ else

328+ liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport})

331329 status <- takeMVar connStatus

332330 pure status

333331

@@ -353,7 +351,7 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

353351 clientNodes <- STMSet.newIO

354352 (localNode, transport) <- createLocalNode

355353 lockMVar <- newMVar digest

356− let conn = InProcessConnection (InProcessConnectionConf {

354+ let conn = InProcessConnection InProcessConnectionConf {

357355 ipPersistenceStrategy = strat,

358356 ipClientNodes = clientNodes,

359357 ipSessions = sessions,

@@ -362,7 +360,7 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

362360 ipLocalNode = localNode,

363361 ipTransport = transport,

364362 ipLocks = Just (lockFileH, lockMVar)

365− })

363+ }

366364

367365 notificationPid <- startNotificationListener localNode notificationCallback

368366 addClientNode conn notificationPid

@@ -372,8 +370,7 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

372370createSessionAtCommit :: Connection -> TransactionId -> IO (Either RelationalError SessionId)

373371createSessionAtCommit conn@(InProcessConnection _) commitId = do

374372 newSessionId <- nextRandom

375− atomically $ do

376− createSessionAtCommit_ commitId newSessionId conn

373+ atomically $ createSessionAtCommit_ commitId newSessionId conn

377374createSessionAtCommit conn@(RemoteProcessConnection _) uuid = remoteCall conn (CreateSessionAtCommit uuid)

378375

379376createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)

@@ -412,7 +409,7 @@ addClientNode (InProcessConnection conf) newProcessId = atomically (STMSet.inser

412409

413410-- | Discards a session, eliminating any uncommitted changes present in the session.

414411closeSession :: SessionId -> Connection -> IO ()

415−closeSession sessionId (InProcessConnection conf) = do

412+closeSession sessionId (InProcessConnection conf) =

416413 atomically $ STMMap.delete sessionId (ipSessions conf)

417414closeSession sessionId conn@(RemoteProcessConnection _) = remoteCall conn (CloseSession sessionId)

418415-- | 'close' cleans up the database access connection and closes any relevant sockets.

@@ -426,7 +423,7 @@ close (InProcessConnection conf) = do

426423 closeTransport (ipTransport conf)

427424

428425close conn@(RemoteProcessConnection conf) = do

429− _ <- (remoteCall conn Logout) :: IO Bool

426+ _ <- remoteCall conn Logout :: IO Bool

430427 closeLocalNode (rLocalNode conf)

431428 closeTransport (rTransport conf)

432429

@@ -440,7 +437,7 @@ closeRemote_ (RemoteProcessConnection conf) = runProcess (rLocalNode conf) (reco

440437--exceptions should generally *NOT* be thrown from any Project:M36 code paths, but third-party code such as AtomFunction scripts could conceivably throw undefined, etc.

441438

442439excEither :: IO (Either RelationalError a) -> IO (Either RelationalError a)

443−excEither m = handle handler m

440+excEither = handle handler

444441 where

445442 handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc

446443 | otherwise = pure (Left (UnhandledExceptionError (show exc)))

@@ -453,7 +450,7 @@ runProcessResult localNode proc = do

453450 liftIO $ putMVar ret val

454451 takeMVar ret

455452

456−safeLogin :: Login -> ProcessId -> Process (Bool)

453+safeLogin :: Login -> ProcessId -> Process Bool

457454safeLogin login procId = do

458455 ret <- call procId login

459456 case ret of

@@ -578,10 +575,10 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

578575 eSession <- sessionForSessionId sessionId sessions

579576 case eSession of

580577 Left err -> pure (Left err)

581− Right session -> do

578+ Right session ->

582579 case Graph.autoMergeToHead (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph of

583580 Left err -> pure (Left err)

584− Right (discon', graph') -> do

581+ Right (discon', graph') ->

585582 pure (Right (discon', graph', [id1, id2, id3]))

586583autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')

587584

@@ -649,10 +646,7 @@ executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

649646 Left err -> pure (Left err)

650647 Right (discon', graph') -> do

651648 --if freshId appears in the graph, then we need to pass it on

652− let transIds = if isRight (transactionForId freshId graph') then

653− [freshId]

654− else

655− []

649+ let transIds = [freshId | isRight (transactionForId freshId graph')]

656650 pure (Right (discon', graph', transIds))

657651{-

658652executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

@@ -767,8 +761,8 @@ commit sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGrap

767761sendNotifications :: [ProcessId] -> LocalNode -> EvaluatedNotifications -> IO ()

768762sendNotifications pids localNode nots = mapM_ sendNots pids

769763 where

770− sendNots remoteClientPid = do

771− when (not (M.null nots)) $ runProcess localNode $ send remoteClientPid (NotificationMessage nots)

764+ sendNots remoteClientPid =

765+ unless (M.null nots) $ runProcess localNode $ send remoteClientPid (NotificationMessage nots)

772766

773767-- | Discard any changes made in the current 'Session' and 'DatabaseContext'. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation.

774768rollback :: SessionId -> Connection -> IO (Either RelationalError ())

@@ -781,7 +775,7 @@ processTransactionGraphPersistence NoPersistence _ _ = pure ()

781775processTransactionGraphPersistence (MinimalPersistence dbdir) transIds graph = transactionGraphPersist NoDiskSync dbdir transIds graph >> pure ()

782776processTransactionGraphPersistence (CrashSafePersistence dbdir) transIds graph = transactionGraphPersist FsyncDiskSync dbdir transIds graph >> pure ()

783777

784−readGraphTransactionIdDigest :: PersistenceStrategy -> IO (LockFileHash)

778+readGraphTransactionIdDigest :: PersistenceStrategy -> IO LockFileHash

785779readGraphTransactionIdDigest NoPersistence = error "attempt to read digest from transaction log without persistence enabled"

786780readGraphTransactionIdDigest (MinimalPersistence dbdir) = readGraphTransactionIdFileDigest dbdir

787781readGraphTransactionIdDigest (CrashSafePersistence dbdir) = readGraphTransactionIdFileDigest dbdir

@@ -917,7 +911,7 @@ atomTypesAsRelation sessionId (InProcessConnection conf) = do

917911 eSession <- sessionForSessionId sessionId sessions

918912 case eSession of

919913 Left err -> pure (Left err)

920− Right session -> do

914+ Right session ->

921915 case typesAsRelation (typeConstructorMapping (Sess.concreteDatabaseContext session)) of

922916 Left err -> pure (Left err)

923917 Right rel -> pure (Right rel)

@@ -930,7 +924,7 @@ disconnectedTransactionIsDirty sessionId (InProcessConnection conf) = do

930924 eSession <- sessionForSessionId sessionId sessions

931925 case eSession of

932926 Left err -> pure (Left err)

933− Right session -> do

927+ Right session ->

934928 pure (Right (isDirty session))

935929disconnectedTransactionIsDirty sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId)

936930

@@ -948,8 +942,7 @@ transactionGraph_ _ = error "remote connection used"

948942disconnectedTransaction_ :: SessionId -> Connection -> IO DisconnectedTransaction

949943disconnectedTransaction_ sessionId (InProcessConnection conf) = do

950944 let sessions = ipSessions conf

951− mSession <- atomically $ do

952− STMMap.lookup sessionId sessions

945+ mSession <- atomically $ STMMap.lookup sessionId sessions

953946 case mSession of

954947 Nothing -> error "No such session"

955948 Just (Sess.Session discon _) -> pure discon

@@ -1010,7 +1003,7 @@ commitLock_ sessionId conf stmBlock = do

10101003 STMMap.insert newSession sessionId sessions

10111004 case transactionForId (Sess.parentId session) oldGraph of

10121005 Left err -> pure $ Left err

1013− Right previousTrans -> do

1006+ Right previousTrans ->

10141007 if not (Prelude.null transactionIdsToPersist) then do

10151008 (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

10161009 nodesToNotify <- toList (STMSet.stream nodes)

src/lib/ProjectM36/DataTypes/Basic.hs+6−6

@@ -8,10 +8,10 @@ import ProjectM36.DataTypes.List

88import ProjectM36.Base

1010basicTypeConstructorMapping :: TypeConstructorMapping

11−basicTypeConstructorMapping = (primitiveTypeConstructorMapping ++

12− maybeTypeConstructorMapping ++

13− eitherTypeConstructorMapping ++

14− listTypeConstructorMapping ++

15− dayTypeConstructorMapping

16− )

11+basicTypeConstructorMapping = primitiveTypeConstructorMapping ++

12+ maybeTypeConstructorMapping ++

13+ eitherTypeConstructorMapping ++

14+ listTypeConstructorMapping ++

15+ dayTypeConstructorMapping

16+

1717

src/lib/ProjectM36/DataTypes/DateTime.hs+1−1

@@ -8,7 +8,7 @@ dateTimeAtomFunctions :: AtomFunctions

88dateTimeAtomFunctions = HS.fromList [ AtomFunction {

99 atomFuncName = "dateTimeFromEpochSeconds",

1010 atomFuncType = [IntAtomType, DateTimeAtomType],

11− atomFuncBody = compiledAtomFunctionBody $ \((IntAtom epoch):_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))

11+ atomFuncBody = compiledAtomFunctionBody $ \(IntAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))

1212 }]

1313

1414

src/lib/ProjectM36/DataTypes/Day.hs+2−2

@@ -8,11 +8,11 @@ dayAtomFunctions :: AtomFunctions

88dayAtomFunctions = HS.fromList [

99 AtomFunction { atomFuncName = "fromGregorian",

1010 atomFuncType = [IntAtomType, IntAtomType, IntAtomType, DayAtomType],

11− atomFuncBody = compiledAtomFunctionBody $ \((IntAtom year):(IntAtom month):(IntAtom day):_) -> pure $ DayAtom (fromGregorian (fromIntegral year) month day)

11+ atomFuncBody = compiledAtomFunctionBody $ \(IntAtom year:IntAtom month:IntAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) month day)

1212 },

1313 AtomFunction { atomFuncName = "dayEarlierThan",

1414 atomFuncType = [DayAtomType, DayAtomType, BoolAtomType],

15− atomFuncBody = compiledAtomFunctionBody $ \((ConstructedAtom _ _ (IntAtom dayA:_)):(ConstructedAtom _ _ (IntAtom dayB:_)):_) -> pure (BoolAtom (dayA < dayB))

15+ atomFuncBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB))

1616 }

1717 ]

1818

src/lib/ProjectM36/DataTypes/Either.hs+1−1

@@ -14,5 +14,5 @@ eitherTypeConstructorMapping = [(ADTypeConstructorDef "Either" ["a", "b"],

1414

1515eitherAtomFunctions :: AtomFunctions

1616eitherAtomFunctions = HS.fromList [

17− compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> pure (BoolAtom (dConsName == "Left"))

17+ compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \(ConstructedAtom dConsName _ _:_) -> pure (BoolAtom (dConsName == "Left"))

1818 ]

src/lib/ProjectM36/DataTypes/Interval.hs+1−3

@@ -1,4 +1,3 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}

21{-# OPTIONS_GHC -fno-warn-orphans #-}

32module ProjectM36.DataTypes.Interval where

43import Data.Interval

@@ -32,6 +31,5 @@ intervalFunctions = [AtomFunction { atomFuncName = "interval_dt_member",

3231 atomFuncType = [dateTimeAtomType,

3332 atomTypeForProxy (Proxy :: Proxy (Interval UTCTime)),

3433 boolAtomType],

35− atomFunc = (\(dt:dtinterval:_) -> Atom $ member ((unsafeCast dt)::UTCTime) ((unsafeCast dtinterval)::(Interval UTCTime)))}

36−

34+ atomFunc = \(dt:dtinterval:_) -> Atom $ member (unsafeCast dt ::UTCTime) (unsafeCast dtinterval :: Interval UTCTime)}

3735 ]

src/lib/ProjectM36/DataTypes/List.hs+1−1

@@ -26,7 +26,7 @@ listMaybeHead :: Atom -> Either AtomFunctionError Atom

2626listMaybeHead (ConstructedAtom "Cons" _ (val:_)) = pure (ConstructedAtom "Just" aType [val])

2727 where

2828 aType = maybeAtomType (atomTypeForAtom val)

29−listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) = do

29+listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) =

3030 case M.lookup "a" tvMap of

3131 Nothing -> Left AtomFunctionTypeMismatchError

3232 Just aType -> pure (ConstructedAtom "Nothing" aType [])

src/lib/ProjectM36/DataTypes/Maybe.hs+2−2

@@ -19,12 +19,12 @@ maybeAtomFunctions = HS.fromList [

1919 AtomFunction {

2020 atomFuncName ="isJust",

2121 atomFuncType = [maybeAtomType (TypeVariableType "a"), BoolAtomType],

22− atomFuncBody = AtomFunctionBody Nothing $ \((ConstructedAtom dConsName _ _):_) -> pure $ BoolAtom (dConsName /= "Nothing")

22+ atomFuncBody = AtomFunctionBody Nothing $ \(ConstructedAtom dConsName _ _:_) -> pure $ BoolAtom (dConsName /= "Nothing")

2323 },

2424 AtomFunction {

2525 atomFuncName = "fromMaybe",

2626 atomFuncType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"],

27− atomFuncBody = AtomFunctionBody Nothing $ \(defaultAtom:(ConstructedAtom dConsName _ (atomVal:_)):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal

27+ atomFuncBody = AtomFunctionBody Nothing $ \(defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal

2828 }

2929 ]

3030

src/lib/ProjectM36/DatabaseContext.hs+1−1

@@ -21,7 +21,7 @@ databaseContextAsDatabaseContextExpr context = MultipleExpr $ relVarsExprs ++ in

2121 where

2222 relVarsExprs = map (\(name, rel) -> Assign name (ExistingRelation rel)) (M.toList (relationVariables context))

2323 incDepsExprs :: [DatabaseContextExpr]

24− incDepsExprs = map (\(name, dep) -> AddInclusionDependency name dep) (M.toList (inclusionDependencies context))

24+ incDepsExprs = map (uncurry AddInclusionDependency) (M.toList (inclusionDependencies context))

2525 funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet

2626

2727basicDatabaseContext :: DatabaseContext

src/lib/ProjectM36/DatabaseContextFunction.hs+2−2

@@ -49,8 +49,8 @@ databaseContextFunctionScript func = case dbcFuncBody func of

4949

5050databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor

5151databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [

52− (ADTypeConstructor "DatabaseContextFunctionError" []),

52+ ADTypeConstructor "DatabaseContextFunctionError" [],

5353 tCons]

5454

5555createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr

56−createScriptedDatabaseContextFunction funcName argsIn retArg script = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg]) script

56+createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])

src/lib/ProjectM36/DatabaseContextFunctionError.hs+1

@@ -4,5 +4,6 @@ import GHC.Generics

44import Data.Binary

55import Control.DeepSeq

7+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

78data DatabaseContextFunctionError = DatabaseContextFunctionUserError String

89 deriving (Generic, Eq, Show, Binary, NFData)

src/lib/ProjectM36/InclusionDependency.hs+2−2

@@ -7,14 +7,14 @@ import qualified Data.Map as M

77import qualified Data.Text as T

99inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation

10−inclusionDependenciesAsRelation incDeps = do

10+inclusionDependenciesAsRelation incDeps =

1111 mkRelationFromList attrs (map incDepAsAtoms (M.toList incDeps))

1212 where

1313 attrs = attributesFromList [Attribute "name" TextAtomType,

1414 Attribute "sub" TextAtomType,

1515 Attribute "super" TextAtomType

1616 ]

17− incDepAsAtoms (name, (InclusionDependency exprA exprB)) = [TextAtom name,

17+ incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name,

1818 TextAtom (T.pack (show exprA)),

1919 TextAtom (T.pack (show exprB))]

2020

src/lib/ProjectM36/IsomorphicSchema.hs+9−14

@@ -39,21 +39,16 @@ isomorphs (Schema i) = i

3939-- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once.

4040--TODO: add relvar must appear exactly once constraint

4141validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError

42−validateSchema potentialSchema baseContext = do

43− if not (S.null rvDiff) then

44− Just (RelVarReferencesMissing rvDiff)

45− else if not (null outDupes) then

46− Just (RelVarOutReferencedMoreThanOnce (head outDupes))

47− else if not (null inDupes) then

48− Just (RelVarInReferencedMoreThanOnce (head inDupes))

49− else

50− Nothing

42+validateSchema potentialSchema baseContext | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff)

43+ | not (null outDupes) = Just (RelVarOutReferencedMoreThanOnce (head outDupes))

44+ | not (null inDupes) = Just (RelVarInReferencedMoreThanOnce (head inDupes))

45+ | otherwise = Nothing

5146 where

5247 --check that the predicate for IsoUnion and IsoRestrict holds right now

5348 outDupes = duplicateNames (namesList isomorphOutRelVarNames)

5449 inDupes = duplicateNames (namesList isomorphInRelVarNames)

5550 duplicateNames = dupes . L.sort

56− namesList isoFunc = concat (map isoFunc (isomorphs potentialSchema))

51+ namesList isoFunc = concatMap isoFunc (isomorphs potentialSchema)

5752 expectedRelVars = M.keysSet (relationVariables baseContext)

5853 schemaRelVars = isomorphsOutRelVarNames (isomorphs potentialSchema)

5954 rvDiff = S.difference expectedRelVars schemaRelVars

@@ -116,15 +111,15 @@ processDatabaseContextExprSchemaUpdate :: Schema -> DatabaseContextExpr -> Schem

116111processDatabaseContextExprSchemaUpdate schema@(Schema morphs) expr = case expr of

117112 Define rv _ | S.notMember rv validSchemaName -> passthru rv

118113 Assign rv _ | S.notMember rv validSchemaName -> passthru rv

119− Undefine rv | S.member rv validSchemaName -> Schema (filter (\morph -> elem rv (isomorphInRelVarNames morph)) morphs)

120− MultipleExpr exprs -> foldr (\expr' schema' -> processDatabaseContextExprSchemaUpdate schema' expr') schema exprs

114+ Undefine rv | S.member rv validSchemaName -> Schema (filter (elem rv . isomorphInRelVarNames) morphs)

115+ MultipleExpr exprs -> foldr (flip processDatabaseContextExprSchemaUpdate) schema exprs

121116 _ -> schema

122117 where

123118 validSchemaName = isomorphsInRelVarNames morphs

124119 passthru rvname = Schema (morphs ++ [IsoRename rvname rvname])

125120

126121processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas

127−processDatabaseContextExprSchemasUpdate subschemas expr = M.map (\schema -> processDatabaseContextExprSchemaUpdate schema expr) subschemas

122+processDatabaseContextExprSchemasUpdate subschemas expr = M.map (`processDatabaseContextExprSchemaUpdate` expr) subschemas

128123

129124-- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema!

130125-- weird compromise: allow inclusion dependencies failures not in the subschema to be propagated- in the worst case, only the inclusion dependency's name is leaked.

@@ -318,7 +313,7 @@ createIncDepsForIsomorph _ _ = M.empty

318313

319314-- in the case of IsoRestrict, the database context should be updated with the restriction so that if the restriction does not hold, then the schema cannot be created

320315evalSchemaExpr :: SchemaExpr -> DatabaseContext -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)

321−evalSchemaExpr (AddSubschema sname morphs) context sschemas = do

316+evalSchemaExpr (AddSubschema sname morphs) context sschemas =

322317 if M.member sname sschemas then

323318 Left (SubschemaNameInUseError sname)

324319 else case valid of

src/lib/ProjectM36/Key.hs+2−2

@@ -27,10 +27,10 @@ inclusionDependencyForKey :: AttributeNames -> RelationalExpr -> InclusionDepend

2727inclusionDependencyForKey attrNames relExpr = --InclusionDependency name (exprCount relExpr) (exprCount (projectedOnKeys relExpr))

2828 InclusionDependency equalityExpr (ExistingRelation relationFalse)

2929 where

30− projectedOnKeys expr = Project attrNames expr

30+ projectedOnKeys = Project attrNames

3131 exprAsSubRelation expr = Extend (AttributeExtendTupleExpr "a" (RelationAtomExpr expr)) (ExistingRelation relationTrue)

3232 exprCount expr = projectionForCount (Extend (AttributeExtendTupleExpr "b" (FunctionAtomExpr "count" [AttributeAtomExpr "a"] () )) (exprAsSubRelation expr))

33− projectionForCount expr = Project (AttributeNames $ S.fromList ["b"]) expr

33+ projectionForCount = Project (AttributeNames $ S.fromList ["b"])

3434 equalityExpr = NotEquals (exprCount relExpr) (exprCount (projectedOnKeys relExpr))

3535

3636-- | Create a 'DatabaseContextExpr' which can be used to add a uniqueness constraint to attributes on one relation variable.

src/lib/ProjectM36/MiscUtils.hs+2−2

@@ -3,7 +3,7 @@ module ProjectM36.MiscUtils where

33--returns duplicates of a pre-sorted list

44dupes :: Eq a => [a] -> [a]

55dupes [] = []

6−dupes (_:[]) = []

7−dupes (x:y:[]) = if x == y then [x] else []

6+dupes [_] = []

7+dupes [x,y] = [x | x == y]

88dupes (x:y:xs) = dupes(x:[y]) ++ dupes(y : xs)

src/lib/ProjectM36/Persist.hs+4−3

@@ -44,8 +44,9 @@ renameSync sync srcPath dstPath = do

4444 syncDirectory sync dstPath

4545

4646-- System.Directory's renameFile/renameDirectory almost do exactly what we want except that it needlessly differentiates between directories and files

47+{-# ANN atomicRename ("HLint: ignore Eta reduce" :: String) #-}

4748atomicRename :: FilePath -> FilePath -> IO ()

48−atomicRename srcPath dstPath = do

49+atomicRename srcPath dstPath =

4950#if defined(mingw32_HOST_OS)

5051 Win32.moveFileEx srcPath dstPath Win32.mOVEFILE_REPLACE_EXISTING

5152#else

@@ -53,7 +54,7 @@ atomicRename srcPath dstPath = do

5354#endif

5455

5556syncHandle :: DiskSync -> Handle -> IO ()

56−syncHandle FsyncDiskSync handle = do

57+syncHandle FsyncDiskSync handle =

5758#if defined(mingw32_HOST_OS)

5859 withHandleToHANDLE handle (\h -> Win32.flushFileBuffers h)

5960#elif defined(linux_HOST_OS)

@@ -69,7 +70,7 @@ syncDirectory FsyncDiskSync path = directoryFsync path

6970syncDirectory NoDiskSync _ = pure ()

7071

7172writeBSFileSync :: DiskSync -> FilePath -> BS.ByteString -> IO ()

72−writeBSFileSync sync path bstring = do

73+writeBSFileSync sync path bstring =

7374 withFile path WriteMode $ \handle -> do

7475 BS.hPut handle bstring

7576 syncHandle sync handle

src/lib/ProjectM36/Relation.hs+12−15

@@ -44,7 +44,7 @@ emptyRelationWithAttrs :: Attributes -> Relation

4444emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet

4545

4646mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation

47−mkRelation attrs tupleSet = do

47+mkRelation attrs tupleSet =

4848 --check that all tuples have the same keys

4949 --check that all tuples have keys (1-N) where N is the attribute count

5050 case verifyTupleSet attrs tupleSet of

@@ -85,7 +85,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

8585 else

8686 Right $ Relation attrs1 newtuples

8787 where

88− newtuples = RelationTupleSet $ HS.toList . HS.fromList $ (asList tupSet1) ++ (map (reorderTuple attrs1) (asList tupSet2))

88+ newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)

8989

9090project :: AttributeNames -> Relation -> Either RelationalError Relation

9191project projectionAttrNames rel =

@@ -95,22 +95,19 @@ project projectionAttrNames rel =

9595 where

9696 folder newAttrs tupleToProject acc = case acc of

9797 Left err -> Left err

98− Right acc2 -> union acc2 (Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject]))

98+ Right acc2 -> acc2 `union` Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject])

9999

100100rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation

101−rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =

102− if not attributeValid

103− then Left $ AttributeNamesMismatchError (S.singleton oldAttrName)

104− else if newAttributeInUse

105− then Left $ AttributeNameInUseError newAttrName

106− else

107− mkRelation newAttrs newTupSet

101+rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet)

102+ | not attributeValid = Left $ AttributeNamesMismatchError (S.singleton oldAttrName)

103+ | newAttributeInUse = Left $ AttributeNameInUseError newAttrName

104+ | otherwise = mkRelation newAttrs newTupSet

108105 where

109106 newAttributeInUse = A.attributeNamesContained (S.singleton newAttrName) (attributeNames rel)

110107 attributeValid = A.attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)

111108 newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs

112109 newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet)

113− tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple

110+ tupsetmapper = tupleRenameAttribute oldAttrName newAttrName

114111

115112--the algebra should return a relation of one attribute and one row with the arity

116113arity :: Relation -> Int

@@ -163,7 +160,7 @@ group groupAttrNames newAttrName rel = do

163160--help restriction function

164161--returns a subrelation of

165162restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation

166−restrictEq tuple rel = restrict rfilter rel

163+restrictEq tuple = restrict rfilter

167164 where

168165 rfilter :: RelationTuple -> Either RelationalError Bool

169166 rfilter tupleIn = pure (tupleIntersection tuple tupleIn == tuple)

@@ -182,7 +179,7 @@ ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of

182179 Left err -> Left err

183180 Right accRel -> do

184181 ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn

185− union accRel ungrouped

182+ accRel `union` ungrouped

186183

187184--take an relval attribute name and a tuple and ungroup the relval

188185tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation

@@ -237,7 +234,7 @@ difference relA relB =

237234

238235--a map should NOT change the structure of a relation, so attributes should be constant

239236relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation

240−relMap mapper (Relation attrs tupleSet) = do

237+relMap mapper (Relation attrs tupleSet) =

241238 case forM (asList tupleSet) typeMapCheck of

242239 Right remappedTupleSet -> mkRelation attrs (RelationTupleSet remappedTupleSet)

243240 Left err -> Left err

@@ -291,7 +288,7 @@ typesAsRelation types = mkRelationFromTuples attrs tuples

291288

292289 mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])

293290

294− mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of

291+ mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of

295292 Left err -> error ("mkRelationFromTuples pooped " ++ show err)

296293 Right rel -> RelationAtom rel

297294

src/lib/ProjectM36/Relation/Parse/CSV.hs+11−10

@@ -15,6 +15,7 @@ import qualified Data.List as L

1515import qualified Data.Text as T

1616import Data.Attoparsec.ByteString.Lazy

1717import ProjectM36.Atom

18+import Control.Arrow

1819

1920data CsvImportError = CsvParseError String |

2021 AttributeMappingError RelationalError |

@@ -27,7 +28,7 @@ csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}

2728--special case from Text- outer quotes are *not* required in CSV, so we have to add them to make it parseable

2829makeAtomFromCSVText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom

2930makeAtomFromCSVText attrName aType textIn = makeAtomFromText attrName aType $ if aType == TextAtomType then

30− ("\"" `T.append` textIn `T.append` "\"")

31+ "\"" `T.append` textIn `T.append` "\""

3132 else

3233 textIn

3334

@@ -37,17 +38,17 @@ csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inStr

3738 Done _ (headerRaw,vecMapsRaw) -> do

3839 let strHeader = V.map decodeUtf8 headerRaw

3940 strMapRecords = V.map convertMap vecMapsRaw

40− convertMap hmap = HM.fromList $ L.map (\(k,v) -> (decodeUtf8 k, (T.unpack . decodeUtf8) v)) (HM.toList hmap)

41+ convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)

4142 attrNames = V.map A.attributeName attrs

4243 attrNameSet = S.fromList (V.toList attrNames)

4344 headerSet = S.fromList (V.toList strHeader)

4445 makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]

45− makeTupleList tupMap = V.toList $ V.map (\attr -> either (Left . AttributeMappingError) Right $ makeAtomFromCSVText (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! (A.attributeName attr))) attrs

46− case attrNameSet == headerSet of

47− False -> Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)

48− True -> do

49− tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)

50− case mkRelationFromList attrs tupleList of

51− Left err -> Left (AttributeMappingError err)

52− Right rel -> Right rel

46+ makeTupleList tupMap = V.toList $ V.map (\attr -> either (Left . AttributeMappingError) Right $ makeAtomFromCSVText (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs

47+ if attrNameSet == headerSet then do

48+ tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)

49+ case mkRelationFromList attrs tupleList of

50+ Left err -> Left (AttributeMappingError err)

51+ Right rel -> Right rel

52+ else

53+ Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)

5354

src/lib/ProjectM36/Relation/Show/CSV.hs+10−7

@@ -13,12 +13,15 @@ import ProjectM36.Atom

1313

1414--spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes

1515relationAsCSV :: Relation -> Either RelationalError BS.ByteString

16−relationAsCSV (Relation attrs tupleSet) = if relValAttrs /= [] then --check for relvalued attributes

17− Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs)

18− else if V.length attrs == 0 then --check that there is at least one attribute

19− Left $ TupleAttributeCountMismatchError 0

20− else

21− Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet)

16+relationAsCSV (Relation attrs tupleSet)

17+ --check for relvalued attributes

18+ | relValAttrs /= [] =

19+ Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs)

20+ --check that there is at least one attribute

21+ | V.null attrs =

22+ Left $ TupleAttributeCountMismatchError 0

23+ | otherwise =

24+ Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet)

2225 where

2326 relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs

2427 bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs

@@ -31,7 +34,7 @@ instance ToRecord RelationTuple where

3134newtype RecordRelationTuple = RecordRelationTuple {unTuple :: RelationTuple}

3235

3336instance ToNamedRecord RecordRelationTuple where

34− toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= (RecordAtom v)) (tupleAssocs $ unTuple rTuple)

37+ toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= RecordAtom v) (tupleAssocs $ unTuple rTuple)

3538

3639instance DefaultOrdered RecordRelationTuple where

3740 headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (tupleAttributes tuple)

src/lib/ProjectM36/Relation/Show/Gnuplot.hs+9−9

@@ -24,13 +24,13 @@ data PlotError = InvalidAttributeCountError |

2424--plotRelation :: Relation -> Either PlotError

2525

2626intFromAtomIndex :: Int -> RelationTuple -> Int

27−intFromAtomIndex index tup = (\i -> castInt i) $ (tupleAtoms tup) V.! index

27+intFromAtomIndex index tup = castInt $ tupleAtoms tup V.! index

2828

2929graph1DRelation :: Relation -> Plot2D.T Int Int

3030graph1DRelation rel = Plot2D.list Graph2D.listPoints $ points1DRelation rel

3131

3232points1DRelation :: Relation -> [Int]

33−points1DRelation rel = relFold folder [] rel

33+points1DRelation = relFold folder []

3434 where

3535 folder tup acc = intFromAtomIndex 0 tup : acc

3636

@@ -38,16 +38,16 @@ graph2DRelation :: Relation -> Plot2D.T Int Int

3838graph2DRelation rel = Plot2D.list Graph2D.points (points2DRelation rel)

3939

4040points2DRelation :: Relation -> [(Int, Int)]

41−points2DRelation rel = relFold folder [] rel

41+points2DRelation = relFold folder []

4242 where

4343 folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup) : acc

4444

4545graph3DRelation :: Relation -> Plot3D.T Int Int Int

46−graph3DRelation rel = do

46+graph3DRelation rel =

4747 Plot3D.cloud Graph3D.points $ points3DRelation rel

4848

4949points3DRelation :: Relation -> [(Int, Int, Int)]

50−points3DRelation rel = relFold folder [] rel

50+points3DRelation = relFold folder []

5151 where

5252 folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup, intFromAtomIndex 2 tup) : acc

5353

@@ -72,11 +72,11 @@ plotRelation :: Relation -> IO (Maybe PlotError)

7272plotRelation rel = let attrTypes = V.replicate (arity rel) IntAtomType in

7373 if attrTypes /= A.atomTypes (attributes rel) then

7474 return $ Just InvalidAttributeTypeError

75− else do

75+ else

7676 case arity rel of

77− 1 -> (GPA.plotDefault $ graph1DRelation rel) >> return Nothing

78− 2 -> (GPA.plotDefault $ graph2DRelation rel) >> return Nothing

79− 3 -> (GPA.plotDefault $ graph3DRelation rel) >> return Nothing

77+ 1 -> GPA.plotDefault (graph1DRelation rel) >> return Nothing

78+ 2 -> GPA.plotDefault (graph2DRelation rel) >> return Nothing

79+ 3 -> GPA.plotDefault (graph3DRelation rel) >> return Nothing

8080 _ -> return $ Just InvalidAttributeCountError

8181

8282

src/lib/ProjectM36/Relation/Show/HTML.hs+3−3

@@ -10,15 +10,15 @@ import qualified Data.Text as T

1010import qualified Data.Text.IO as TIO

1111

1212attributesAsHTML :: Attributes -> Text

13−attributesAsHTML attrs = "<tr>" `append` (T.concat $ map oneAttrHTML attrNameList) `append` "</tr>"

13+attributesAsHTML attrs = "<tr>" `append` T.concat (map oneAttrHTML attrNameList) `append` "</tr>"

1414 where

1515 oneAttrHTML attrName = "<th>" `append` attrName `append` "</th>"

1616 attrNameList = sortedAttributeNameList (attributeNameSet attrs)

1717

1818relationAsHTML :: Relation -> Text

19−relationAsHTML rel@(Relation attrNameSet tupleSet) = "<table border=\"1\">" `append` (attributesAsHTML attrNameSet) `append` (tupleSetAsHTML tupleSet) `append` "<tfoot>" `append` tablefooter `append` "</tfoot></table>"

19+relationAsHTML rel@(Relation attrNameSet tupleSet) = "<table border=\"1\">" `append` attributesAsHTML attrNameSet `append` tupleSetAsHTML tupleSet `append` "<tfoot>" `append` tablefooter `append` "</tfoot></table>"

2020 where

21− tablefooter = "<tr><td colspan=\"100%\">" `append` (pack $ show (cardinality rel)) `append` " tuples</td></tr>"

21+ tablefooter = "<tr><td colspan=\"100%\">" `append` pack (show (cardinality rel)) `append` " tuples</td></tr>"

2222

2323writeHTML :: Text -> IO ()

2424writeHTML = TIO.writeFile "/home/agentm/rel.html"

src/lib/ProjectM36/Relation/Show/Term.hs+15−14

@@ -5,10 +5,11 @@ import ProjectM36.Atom

55import ProjectM36.AtomType

66import ProjectM36.Tuple

77import ProjectM36.Relation

8−import ProjectM36.Attribute

8+import ProjectM36.Attribute hiding (null)

99import qualified Data.List as L

1010import qualified Data.Text as T

1111import qualified Data.Vector as V

12+import Control.Arrow hiding (left)

1213

1314boxV :: StringType

1415boxV = "│"

@@ -60,10 +61,10 @@ cellLocations tab@(header, _) = (maxWidths, maxHeights)

6061 where

6162 cellSizeMatrix = cellSizes tab

6263 maxWidths = foldl mergeMax (baseSize (length header)) (map fst cellSizeMatrix)

63− baseSize num = take num (repeat 0)

64+ baseSize num = replicate num 0

6465 rowHeights = map snd cellSizeMatrix

65− maxHeights = map (\l -> if length l == 0 then 0 else L.maximumBy compare l) rowHeights

66− mergeMax a b = map (\(c,d) -> max c d) (zip a b)

66+ maxHeights = map (\l -> if null l then 0 else L.maximum l) rowHeights

67+ mergeMax = zipWith max

6768

6869--the normal "lines" function returns an empty list for an empty string which is not what we want

6970breakLines :: StringType -> [StringType]

@@ -71,14 +72,14 @@ breakLines "" = [""]

7172breakLines x = T.lines x

7273

7374cellSizes :: Table -> [([Int], [Int])]

74−cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows

75+cellSizes (header, body) = map (map maxRowWidth &&& map (length . breakLines)) allRows

7576 where

76− maxRowWidth row = if length (lengths row) == 0 then

77+ maxRowWidth row = if null (lengths row) then

7778 0

7879 else

79− L.maximumBy compare (lengths row)

80+ L.maximum (lengths row)

8081 lengths row = map T.length (breakLines row)

81− allRows = [header] ++ body

82+ allRows = header : body

8283

8384relationAsTable :: Relation -> Table

8485relationAsTable rel@(Relation _ tupleSet) = (header, body)

@@ -101,7 +102,7 @@ showParens predicate f = if predicate then

101102

102103showAtom :: Int -> Atom -> StringType

103104showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel

104−showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && length atoms >= 1) $ T.concat (L.intersperse " " (dConsName : (map (showAtom 1) atoms)))

105+showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && not (null atoms)) $ T.concat (L.intersperse " " (dConsName : map (showAtom 1) atoms))

105106showAtom _ atom = atomToText atom

106107

107108renderTable :: Table -> StringType

@@ -112,13 +113,13 @@ renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd

112113renderHeader :: Table -> [Int] -> StringType

113114renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHeaderNames `T.append` renderBottomBar

114115 where

115− renderTopBar = boxTL `T.append` T.concat (L.intersperse boxTB (map (\x -> repeatString x boxH) columnLocations)) `T.append` boxTR `T.append` "\n"

116+ renderTopBar = boxTL `T.append` T.concat (L.intersperse boxTB (map (`repeatString` boxH) columnLocations)) `T.append` boxTR `T.append` "\n"

116117 renderHeaderNames = renderRow header columnLocations 1 boxV

117− renderBottomBar = if length body == 0 then ""

118+ renderBottomBar = if null body then ""

118119 else renderHBar boxLB boxC boxRB columnLocations `T.append` "\n"

119120

120121renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType

121−renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end

122+renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (`repeatString` boxH) columnLocations)) `T.append` end

122123

123124leftPaddedString :: Int -> Int -> StringType -> StringType

124125leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then

@@ -131,7 +132,7 @@ leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then

131132renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType

132133renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1]

133134 where

134− renderOneLine lineNum = boxV `T.append` T.concat (L.intersperse interspersed (map (\(size, value) -> leftPaddedString lineNum size value) (zip columnLocations cells))) `T.append` boxV

135+ renderOneLine lineNum = boxV `T.append` T.concat (L.intersperse interspersed (zipWith (leftPaddedString lineNum) columnLocations cells)) `T.append` boxV

135136

136137renderBody :: [[Cell]] -> ([Int],[Int]) -> StringType

137138renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar

@@ -149,7 +150,7 @@ orderedAttributeNames :: Relation -> [AttributeName]

149150orderedAttributeNames rel = map attributeName (orderedAttributes rel)

150151

151152repeatString :: Int -> StringType -> StringType

152−repeatString c s = T.concat (take c (repeat s))

153+repeatString c s = T.concat (replicate c s)

153154

154155showRelation :: Relation -> StringType

155156showRelation rel = renderTable (relationAsTable rel)

src/lib/ProjectM36/RelationalExpression.hs+48−54

@@ -34,9 +34,7 @@ databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc

3434databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups

3535 where

3636 attrs = A.attributesFromList [Attribute "count" IntAtomType]

37− existingTuple = case singletonTuple relIn of

38− Just t -> t

39− Nothing -> error "impossible counting error in singletonTuple"

37+ existingTuple = fromMaybe (error "impossible counting error in singletonTuple") (singletonTuple relIn)

4038 existingCount = case V.head (tupleAtoms existingTuple) of

4139 IntAtom v -> v

4240 _ -> error "impossible counting error in tupleAtoms"

@@ -59,7 +57,7 @@ instance Show RelationalExprStateElems where

5957 show (RelationalExprStateElems _) = "RelationalExprStateElems"

6058

6159mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems

62−mkRelationalExprState ctx = RelationalExprStateElems ctx

60+mkRelationalExprState = RelationalExprStateElems

6361

6462mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems

6563mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn

@@ -84,7 +82,7 @@ type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, D

8482

8583type DatabaseState a = State DatabaseStateElems a

8684

87−getStateContext :: DatabaseState (DatabaseContext)

85+getStateContext :: DatabaseState DatabaseContext

8886getStateContext = do

8987 (ctx,_, _) <- get

9088 pure ctx

@@ -109,7 +107,7 @@ setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExp

109107--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

110108evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

111109evalRelationalExpr (RelationVariable name _) = do

112− relvarTable <- liftM (relationVariables . stateElemsContext) ask

110+ relvarTable <- fmap (relationVariables . stateElemsContext) ask

113111 return $ case M.lookup name relvarTable of

114112 Just res -> Right res

115113 Nothing -> Left $ RelVarNotDefinedError name

@@ -147,24 +145,24 @@ evalRelationalExpr (Difference exprA exprB) = do

147145 Left err -> return $ Left err

148146 Right relB2 -> return $ difference relA2 relB2

149147

150−evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

148+evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

151149 case mkRelation attributeSet tupleSet of

152150 Right rel -> return $ Right rel

153151 Left err -> return $ Left err

154152

155153evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

156− currentContext <- liftM stateElemsContext ask

154+ currentContext <- fmap stateElemsContext ask

157155 let tConss = typeConstructorMapping currentContext

158156 -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible

159157 runExceptT $ do

160158 mAttrs <- case mAttrExprs of

161159 Just _ -> do

162− attrs <- mapM (\expr -> either throwE pure (evalAttrExpr tConss expr)) (fromMaybe [] mAttrExprs)

160+ attrs <- mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

163161 pure (Just (A.attributesFromList attrs))

164162 Nothing -> pure Nothing

165− tuples <- mapM (\expr -> liftE (evalTupleExpr mAttrs expr)) tupleExprs

163+ tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

166164 let attrs = fromMaybe firstTupleAttrs mAttrs

167− firstTupleAttrs = if length tuples == 0 then A.emptyAttributes else tupleAttributes (head tuples)

165+ firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

168166 either throwE pure (mkRelation attrs (RelationTupleSet tuples))

169167

170168evalRelationalExpr (ExistingRelation rel) = pure (Right rel)

@@ -195,7 +193,7 @@ evalRelationalExpr (Restrict predicateExpr relExpr) = do

195193 eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr

196194 case eFilterFunc of

197195 Left err -> return $ Left err

198− Right filterfunc -> do

196+ Right filterfunc ->

199197 pure (restrict filterfunc rel)

200198

201199evalRelationalExpr (Equals relExprA relExprB) = do

@@ -259,8 +257,8 @@ evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe Relationa

259257evalDatabaseContextExpr NoOperation = pure Nothing

260258

261259evalDatabaseContextExpr (Define relVarName attrExprs) = do

262− relvars <- liftM relationVariables getStateContext

263− tConss <- liftM typeConstructorMapping getStateContext

260+ relvars <- fmap relationVariables getStateContext

261+ tConss <- fmap typeConstructorMapping getStateContext

264262 let eAttrs = map (evalAttrExpr tConss) attrExprs

265263 case lefts eAttrs of

266264 err:_ -> pure (Just err)

@@ -271,8 +269,7 @@ evalDatabaseContextExpr (Define relVarName attrExprs) = do

271269 attrs = A.attributesFromList (rights eAttrs)

272270 emptyRelation = Relation attrs emptyTupleSet

273271

274−evalDatabaseContextExpr (Undefine relVarName) = do

275− deleteRelVar relVarName

272+evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName

276273

277274evalDatabaseContextExpr (Assign relVarName expr) = do

278275 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it

@@ -326,7 +323,7 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)

326323 let relVarTable = relationVariables context

327324 case M.lookup relVarName relVarTable of

328325 Nothing -> return $ Just (RelVarNotDefinedError relVarName)

329− Just rel -> do

326+ Just rel ->

330327 case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of

331328 Left err -> return $ Just err

332329 Right predicateFunc -> do

@@ -335,9 +332,9 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)

335332 if cardinality restrictedPortion == Finite 0 then

336333 pure Nothing

337334 else do

338− unrestrictedPortion <- restrict (\tup -> predicateFunc tup >>= pure . not) rel

335+ unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel

339336 updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion

340− updatedRel <- union updatedPortion unrestrictedPortion

337+ updatedRel <- updatedPortion `union` unrestrictedPortion

341338 pure (Just updatedRel)

342339 case ret of

343340 Left err -> pure (Just err)

@@ -400,21 +397,18 @@ evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

400397 -- validate that the constructor's types exist

401398 case validateTypeConstructorDef tConsDef dConsDefList of

402399 errs@(_:_) -> pure $ Just (someErrors errs)

403− [] -> do

404− if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then

405− pure $ Just (InvalidAtomTypeName tConsName)

406− else if isJust (findTypeConstructor tConsName oldTypes) then

407− pure $ Just (AtomTypeNameInUseError tConsName)

408− else do

409− let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]

410− putStateContext $ currentContext { typeConstructorMapping = newTypes }

411− pure Nothing

400+ [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure $ Just (InvalidAtomTypeName tConsName)

401+ | isJust (findTypeConstructor tConsName oldTypes) -> pure $ Just (AtomTypeNameInUseError tConsName)

402+ | otherwise -> do

403+ let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]

404+ putStateContext $ currentContext { typeConstructorMapping = newTypes }

405+ pure Nothing

412406

413407-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.

414408evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

415409 currentContext <- getStateContext

416410 let oldTypes = typeConstructorMapping currentContext

417− if findTypeConstructor tConsName oldTypes == Nothing then

411+ if isNothing (findTypeConstructor tConsName oldTypes) then

418412 pure $ Just (AtomTypeNameNotInUseError tConsName)

419413 else do

420414 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes

@@ -426,8 +420,8 @@ evalDatabaseContextExpr (MultipleExpr exprs) = do

426420 evald <- forM exprs evalDatabaseContextExpr

427421 --some lifting magic needed here

428422 case catMaybes evald of

429− [] -> return $ Nothing

430− err:_ -> return $ Just err

423+ [] -> pure Nothing

424+ err:_ -> pure (Just err)

431425

432426evalDatabaseContextExpr (RemoveAtomFunction funcName) = do

433427 currentContext <- getStateContext

@@ -467,7 +461,7 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =

467461 actualArgCount = length atomArgExprs

468462 if expectedArgCount /= actualArgCount then

469463 pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))

470− else do

464+ else

471465 --check that the atom types are valid

472466 case lefts eAtomTypes of

473467 _:_ -> pure (Just (someErrors (lefts eAtomTypes)))

@@ -480,15 +474,15 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =

480474 eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs

481475 if length (lefts eAtomArgs) > 1 then

482476 pure (Just (someErrors (lefts eAtomArgs)))

483− else if length typeErrors > 0 then

477+ else if not (null typeErrors) then

484478 pure (Just (someErrors typeErrors))

485− else do

479+ else

486480 case evalDatabaseContextFunction func (rights eAtomArgs) context of

487481 Left err -> pure (Just err)

488482 Right newContext -> putStateContext newContext >> pure Nothing

489483

490484evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)

491−evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do

485+evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =

492486 case mScriptSession of

493487 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

494488 Just scriptSession -> do

@@ -512,7 +506,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam

512506 -- check if the name is already in use

513507 if HS.member funcName (HS.map atomFuncName atomFuncs) then

514508 Left (FunctionNameInUseError funcName)

515− else do

509+ else

516510 Right newContext

517511 case res of

518512 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))

@@ -520,7 +514,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam

520514 Left err -> pure (Left err)

521515 Right context' -> pure (Right context')

522516

523−evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) = do

517+evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) =

524518 case mScriptSession of

525519 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

526520 Just scriptSession -> do

@@ -552,7 +546,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

552546 -- check if the name is already in use

553547 if HS.member funcName (HS.map dbcFuncName dbcFuncs) then

554548 Left (FunctionNameInUseError funcName)

555− else do

549+ else

556550 Right newContext

557551 case res of

558552 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))

@@ -561,7 +555,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

561555 Right context' -> pure (Right context')

562556

563557

564−updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

558+updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

565559updateTupleWithAtomExprs exprMap context tupIn = do

566560 --resolve all atom exprs

567561 atomsAssoc <- mapM (\(attrName, atomExpr) -> do

@@ -616,7 +610,7 @@ liftE v = do

616610

617611{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

618612predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)

619−predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do

613+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =

620614 runExceptT $ do

621615 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

622616 expr2v <- liftE (predicateRestrictionFilter attrs expr2)

@@ -625,7 +619,7 @@ predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do

625619 ev2 <- expr2v x

626620 pure (ev1 && ev2))

627621

628−predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do

622+predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =

629623 runExceptT $ do

630624 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

631625 expr2v <- liftE (predicateRestrictionFilter attrs expr2)

@@ -636,7 +630,7 @@ predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do

636630

637631predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))

638632

639−predicateRestrictionFilter attrs (NotPredicate expr) = do

633+predicateRestrictionFilter attrs (NotPredicate expr) =

640634 runExceptT $ do

641635 exprv <- liftE (predicateRestrictionFilter attrs expr)

642636 pure (\x -> do

@@ -691,7 +685,7 @@ predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

691685 if aType /= BoolAtomType then

692686 throwE (AtomTypeMismatchError aType BoolAtomType)

693687 else

694− pure (\tupleIn -> do

688+ pure (\tupleIn ->

695689 pure $ case runReader (evalAtomExpr tupleIn atomExpr) rstate of

696690 Left _ -> False

697691 Right boolAtomValue -> boolAtomValue == BoolAtom True)

@@ -713,7 +707,7 @@ extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomE

713707 atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)

714708 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

715709 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

716− pure $ (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of

710+ pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of

717711 Left err -> Left err

718712 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

719713 )

@@ -731,7 +725,7 @@ evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attr

731725evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)

732726evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

733727 argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments

734− context <- liftM stateElemsContext ask

728+ context <- fmap stateElemsContext ask

735729 runExceptT $ do

736730 let functions = atomFunctions context

737731 func <- either throwE pure (atomFunctionForName funcName functions)

@@ -744,7 +738,7 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

744738 throwE (FunctionArgumentCountMismatch expectedArgCount actualArgCount)

745739 else do

746740 _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))

747− evaldArgs <- mapM (\arg -> liftE (evalAtomExpr tupIn arg)) arguments

741+ evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments

748742 case evalAtomFunction func evaldArgs of

749743 Left err -> throwE (AtomFunctionUserError err)

750744 Right result -> pure result

@@ -778,13 +772,13 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

778772 Left err -> pure (error "GONK" $ Left err)

779773typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))

780774typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

781− context <- liftM stateElemsContext ask

775+ context <- fmap stateElemsContext ask

782776 let funcs = atomFunctions context

783777 case atomFunctionForName funcName funcs of

784778 Left err -> pure (Left err)

785779 Right func -> do

786780 let funcRetType = last (atomFuncType func)

787− funcArgTypes = reverse (tail (reverse (atomFuncType func)))

781+ funcArgTypes = init (atomFuncType func)

788782 eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs

789783 case lefts eArgTypes of

790784 errs@(_:_) -> pure (Left (someErrors errs))

@@ -801,8 +795,8 @@ typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

801795-- grab the type of the data constructor, then validate that the args match the expected types

802796typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

803797 runExceptT $ do

804− argsTypes <- mapM (\arg -> liftE (typeFromAtomExpr attrs arg)) dConsArgs

805− context <- liftM stateElemsContext (lift ask)

798+ argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs

799+ context <- fmap stateElemsContext (lift ask)

806800 aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

807801 pure aType

808802

@@ -829,18 +823,18 @@ verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedTyp

829823 let expectedArgTypes = atomFuncType func

830824 funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of

831825 Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)

832− Left err -> throwE (err)

826+ Left err -> throwE err

833827 Right x -> pure x

834828 ) $ zip3 funcArgExprs expectedArgTypes [1..]

835829 if length funcArgTypes /= length expectedArgTypes - 1 then

836830 throwE (AtomTypeCountError funcArgTypes expectedArgTypes)

837− else do

831+ else

838832 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))

839833verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do

840834 rstate <- lift ask

841835 relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))

842836 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))

843−verifyAtomExprTypes rel cons@(ConstructedAtomExpr _ _ _) expectedType = runExceptT $ do

837+verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do

844838 cType <- liftE (typeFromAtomExpr (attributes rel) cons)

845839 either throwE pure (atomTypeVerify expectedType cType)

846840

@@ -854,7 +848,7 @@ evalAttrExpr _ (NakedAttributeExpr attr) = Right attr

854848

855849evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)

856850evalTupleExpr attrs (TupleExpr tupMap) = do

857− context <- liftM stateElemsContext ask

851+ context <- fmap stateElemsContext ask

858852 runExceptT $ do

859853 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority

860854 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed

src/lib/ProjectM36/ScriptBase.hsdeleted−4

@@ -1,4 +0,0 @@

1−module ProjectM36.ScriptBase where

2−import Prelude

3−

4−data Atom = IntAtom Int

src/lib/ProjectM36/ScriptSession.hs+5−5

@@ -30,7 +30,7 @@ data ScriptSession = ScriptSession {

3030 dbcFunctionBodyType :: Type

3131 }

3232

33−data ScriptSessionError = ScriptSessionLoadError GhcException

33+newtype ScriptSessionError = ScriptSessionLoadError GhcException

3434 deriving (Show)

3535

3636-- | Configure a GHC environment/session which we will use for all script compilation.

@@ -44,7 +44,7 @@ initScriptSession ghcPkgPaths = do

4444 dflags <- getSessionDynFlags

4545 let ghcVersion = projectVersion dflags

4646

47− sandboxPkgPaths <- liftIO $ liftM concat $ mapM glob [

47+ sandboxPkgPaths <- liftIO $ concat <$> mapM glob [

4848 "./dist-newstyle/packagedb/ghc-" ++ ghcVersion,

4949 ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d",

5050 homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"

@@ -61,7 +61,7 @@ initScriptSession ghcPkgPaths = do

6161#if __GLASGOW_HASKELL__ >= 800

6262 trustFlags = map TrustPackage required_packages,

6363#endif

64− packageFlags = (packageFlags dflags) ++ packages,

64+ packageFlags = packageFlags dflags ++ packages,

6565 extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])

6666 }

6767 applyGopts flags = foldl gopt_set flags gopts

@@ -100,7 +100,7 @@ initScriptSession ghcPkgPaths = do

100100 ideclSource = False,

101101 ideclSafe = True,

102102 ideclImplicit = False,

103− ideclQualified = (isJust mQual),

103+ ideclQualified = isJust mQual,

104104 ideclAs = mQual,

105105 ideclHiding = Nothing

106106 }

@@ -139,7 +139,7 @@ mkTypeForName name = do

139139 case lBodyName of

140140 [] -> error ("failed to parse " ++ name)

141141 _:_:_ -> error "too many name matches"

142− bodyName:[] -> do

142+ [bodyName] -> do

143143 mThing <- lookupName bodyName

144144 case mThing of

145145 Nothing -> error ("failed to find " ++ name)

src/lib/ProjectM36/Server.hs+2−2

@@ -75,7 +75,7 @@ loggingNotificationCallback :: NotificationCallback

7575loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot

7676

7777-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.

78−launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO (Bool)

78+launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool

7979launchServer daemonConfig mAddressMVar = do

8080 econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))

8181 case econn of

@@ -98,7 +98,7 @@ launchServer daemonConfig mAddressMVar = do

9898 runProcess localTCPNode $ do

9999 let testBool = testMode daemonConfig

100100 reqTimeout = perRequestTimeout daemonConfig

101− serve (conn, databaseName daemonConfig, mAddressMVar, (address endpoint)) initServer (serverDefinition testBool reqTimeout)

101+ serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)

102102 liftIO $ putStrLn "serve returned"

103103 pure True

104104

src/lib/ProjectM36/Server/EntryPoints.hs+3−3

@@ -13,7 +13,7 @@ import Data.Map

1313import Control.Concurrent (threadDelay)

1414

1515timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a)

16−timeoutOrDie micros act = do

16+timeoutOrDie micros act =

1717 if micros == 0 then

1818 liftIO act >>= \x -> pure (Right x)

1919 else do

@@ -131,9 +131,9 @@ handleExecuteSchemaExpr ti sessionId conn schemaExpr = do

131131 reply ret conn

132132

133133handleLogout :: Timeout -> Connection -> Reply Bool

134−handleLogout _ conn = do

134+handleLogout _ =

135135 --liftIO $ closeRemote_ conn

136− reply (pure True) conn

136+ reply (pure True)

137137

138138handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool

139139handleTestTimeout ti _ conn = do

src/lib/ProjectM36/Server/RemoteCallTypes.hs+1

@@ -9,6 +9,7 @@ import GHC.Generics

99import Data.Binary

1010import Control.Distributed.Process (ProcessId)

1111

12+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

1213-- | The initial login message. The argument should be the process id of the initiating client. This ProcessId will receive notification callbacks.

1314data Login = Login ProcessId

1415 deriving (Binary, Generic)

src/lib/ProjectM36/StaticOptimizer.hs+27−26

@@ -28,15 +28,16 @@ applyStaticRelationalOptimization (Project attrNameSet expr) = do

2828 relType <- typeForRelationalExpr expr

2929 case relType of

3030 Left err -> return $ Left err

31− Right relType2 -> if AS.all == attrNameSet then

32− applyStaticRelationalOptimization expr

33− else if AttributeNames (attributeNames relType2) == attrNameSet then

34− applyStaticRelationalOptimization expr

35− else do

36− optimizedSubExpression <- applyStaticRelationalOptimization expr

37− case optimizedSubExpression of

38− Left err -> return $ Left err

39− Right optSubExpr -> return $ Right $ Project attrNameSet optSubExpr

31+ Right relType2

32+ | AS.all == attrNameSet ->

33+ applyStaticRelationalOptimization expr

34+ | AttributeNames (attributeNames relType2) == attrNameSet ->

35+ applyStaticRelationalOptimization expr

36+ | otherwise -> do

37+ optimizedSubExpression <- applyStaticRelationalOptimization expr

38+ case optimizedSubExpression of

39+ Left err -> pure $ Left err

40+ Right optSubExpr -> pure $ Right $ Project attrNameSet optSubExpr

4041

4142applyStaticRelationalOptimization (Union exprA exprB) = do

4243 optExprA <- applyStaticRelationalOptimization exprA

@@ -77,12 +78,12 @@ applyStaticRelationalOptimization (Difference exprA exprB) = do

7778 else

7879 return $ Right (Difference optExprA2 optExprB2)

7980

80−applyStaticRelationalOptimization e@(Rename _ _ _) = return $ Right e

81+applyStaticRelationalOptimization e@Rename{} = return $ Right e

8182

82−applyStaticRelationalOptimization (Group oldAttrNames newAttrName expr) = do

83+applyStaticRelationalOptimization (Group oldAttrNames newAttrName expr) =

8384 return $ Right $ Group oldAttrNames newAttrName expr

8485

85−applyStaticRelationalOptimization (Ungroup attrName expr) = do

86+applyStaticRelationalOptimization (Ungroup attrName expr) =

8687 return $ Right $ Ungroup attrName expr

8788

8889--remove restriction of nothing

@@ -90,18 +91,18 @@ applyStaticRelationalOptimization (Restrict predicate expr) = do

9091 optimizedPredicate <- applyStaticPredicateOptimization predicate

9192 case optimizedPredicate of

9293 Left err -> return $ Left err

93− Right optimizedPredicate2 -> if optimizedPredicate2 == TruePredicate then

94− applyStaticRelationalOptimization expr

95− else if optimizedPredicate2 == NotPredicate TruePredicate then do

96− attributesRel <- typeForRelationalExpr expr

97− case attributesRel of

98− Left err -> return $ Left err

99− Right attributesRelA -> return $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet

100− else do

101− optimizedSubExpression <- applyStaticRelationalOptimization expr

102− case optimizedSubExpression of

103− Left err -> return $ Left err

104− Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr

94+ Right optimizedPredicate2

95+ | optimizedPredicate2 == TruePredicate -> applyStaticRelationalOptimization expr

96+ | optimizedPredicate2 == NotPredicate TruePredicate -> do

97+ attributesRel <- typeForRelationalExpr expr

98+ case attributesRel of

99+ Left err -> return $ Left err

100+ Right attributesRelA -> return $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet

101+ | otherwise -> do

102+ optimizedSubExpression <- applyStaticRelationalOptimization expr

103+ case optimizedSubExpression of

104+ Left err -> return $ Left err

105+ Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr

105106

106107applyStaticRelationalOptimization e@(Equals _ _) = return $ Right e

107108

@@ -172,9 +173,9 @@ applyStaticDatabaseOptimization c@(ExecuteDatabaseContextFunction _ _) = pure (R

172173--for multiple expressions, we must evaluate

173174applyStaticDatabaseOptimization (MultipleExpr exprs) = do

174175 context <- getStateContext

175− let optExprs = evalState substateRunner ((contextWithEmptyTupleSets context), M.empty, False)

176+ let optExprs = evalState substateRunner (contextWithEmptyTupleSets context, M.empty, False)

176177 let errors = lefts optExprs

177− if length errors > 0 then

178+ if not (null errors) then

178179 return $ Left (head errors)

179180 else

180181 return $ Right $ MultipleExpr (rights optExprs)

src/lib/ProjectM36/Transaction/Persist.hs+21−22

@@ -59,7 +59,7 @@ readTransaction dbdir transId mScriptSession = do

5959 return $ Left $ MissingTransactionError transId

6060 else do

6161 relvars <- readRelVars transDir

62− transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)

62+ transInfo <- B.decode <$> BS.readFile (transactionInfoPath transDir)

6363 incDeps <- readIncDeps transDir

6464 typeCons <- readTypeConstructorMapping transDir

6565 sschemas <- readSubschemas transDir

@@ -80,7 +80,7 @@ writeTransaction sync dbdir trans = do

8080 finalTransDir = transactionDir dbdir (transactionId trans)

8181 context = concreteDatabaseContext trans

8282 transDirExists <- doesDirectoryExist finalTransDir

83− if not transDirExists then do

83+ unless transDirExists $ do

8484 --create sub directories

8585 mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, atomFuncsDir tempTransDir, dbcFuncsDir tempTransDir]

8686 writeRelVars sync tempTransDir (relationVariables context)

@@ -92,15 +92,14 @@ writeTransaction sync dbdir trans = do

9292 BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)

9393 --move the temp directory to final location

9494 renameSync sync tempTransDir finalTransDir

95− else

96− return ()

95+ pure ()

9796

9897writeRelVar :: DiskSync -> FilePath -> (RelVarName, Relation) -> IO ()

9998writeRelVar sync transDir (relvarName, rel) = do

10099 let relvarPath = relvarsDir transDir </> T.unpack relvarName

101100 writeBSFileSync sync relvarPath (B.encode rel)

102101

103−writeRelVars :: DiskSync -> FilePath -> (M.Map RelVarName Relation) -> IO ()

102+writeRelVars :: DiskSync -> FilePath -> M.Map RelVarName Relation -> IO ()

104103writeRelVars sync transDir relvars = mapM_ (writeRelVar sync transDir) $ M.toList relvars

105104

106105readRelVars :: FilePath -> IO (M.Map RelVarName Relation)

@@ -108,7 +107,7 @@ readRelVars transDir = do

108107 let relvarsPath = relvarsDir transDir

109108 relvarNames <- getDirectoryNames relvarsPath

110109 relvars <- mapM (\name -> do

111− rel <- liftM B.decode $ BS.readFile (relvarsPath </> name)

110+ rel <- B.decode <$> BS.readFile (relvarsPath </> name)

112111 return (T.pack name, rel)) relvarNames

113112 return $ M.fromList relvars

114113

@@ -121,7 +120,7 @@ readAtomFuncs transDir mScriptSession = do

121120 funcNames <- getDirectoryNames (atomFuncsDir transDir)

122121 --only Haskell script functions can be serialized

123122 --we always return the pre-compiled functions

124− funcs <- mapM (\name -> readAtomFunc transDir name mScriptSession precompiledAtomFunctions) (map T.pack funcNames)

123+ funcs <- mapM ((\name -> readAtomFunc transDir name mScriptSession precompiledAtomFunctions) . T.pack) funcNames

125124 pure (HS.union precompiledAtomFunctions (HS.fromList funcs))

126125

127126--to write the atom functions, we really some bytecode to write (GHCi bytecode?)

@@ -131,10 +130,10 @@ writeAtomFunc sync transDir func = do

131130 writeBSFileSync sync atomFuncPath (B.encode (atomFuncType func, atomFunctionScript func))

132131

133132--if the script session is enabled, compile the script, otherwise, hard error!

134−readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO (AtomFunction)

133+readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction

135134readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

136135 let atomFuncPath = atomFuncsDir transDir </> T.unpack funcName

137− (funcType, mFuncScript) <- liftM B.decode (BS.readFile atomFuncPath)

136+ (funcType, mFuncScript) <- B.decode <$> BS.readFile atomFuncPath

138137 case mFuncScript of

139138 --handle pre-compiled case- pull it from the precompiled list

140139 Nothing -> case atomFunctionForName funcName precompiledFuncs of

@@ -142,7 +141,7 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

142141 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)

143142 Right realFunc -> pure realFunc

144143 --handle a real Haskell scripted function- compile and load

145− Just funcScript -> do

144+ Just funcScript ->

146145 case mScriptSession of

147146 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"

148147 Just scriptSession -> do

@@ -152,9 +151,9 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do

152151 compileScript (atomFunctionBodyType scriptSession) funcScript

153152 case eCompiledScript of

154153 Left err -> throwIO err

155− Right compiledScript -> pure (AtomFunction { atomFuncName = funcName,

154+ Right compiledScript -> pure AtomFunction { atomFuncName = funcName,

156155 atomFuncType = funcType,

157− atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript })

156+ atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }

158157

159158writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()

160159writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toList funcs)

@@ -169,18 +168,18 @@ readDBCFuncs transDir mScriptSession = do

169168 funcNames <- getDirectoryNames (dbcFuncsDir transDir)

170169 --only Haskell script functions can be serialized

171170 --we always return the pre-compiled functions

172− funcs <- mapM (\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) (map T.pack funcNames)

171+ funcs <- mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames

173172 return $ HS.union basicDatabaseContextFunctions (HS.fromList funcs)

174173

175174readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction

176175readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

177176 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName

178− (funcType, mFuncScript) <- liftM B.decode (BS.readFile dbcFuncPath)

177+ (funcType, mFuncScript) <- B.decode <$> BS.readFile dbcFuncPath

179178 case mFuncScript of

180179 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of

181180 Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)

182181 Right realFunc -> pure realFunc --return precompiled function

183− Just funcScript -> do

182+ Just funcScript ->

184183 case mScriptSession of

185184 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"

186185 Just scriptSession -> do

@@ -189,12 +188,12 @@ readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

189188 compileScript (dbcFunctionBodyType scriptSession) funcScript

190189 case eCompiledScript of

191190 Left err -> throwIO err

192− Right compiledScript -> pure (DatabaseContextFunction { dbcFuncName = funcName,

191+ Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName,

193192 dbcFuncType = funcType,

194− dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript})

193+ dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}

195194

196195writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()

197−writeIncDep sync transDir (incDepName, incDep) = do

196+writeIncDep sync transDir (incDepName, incDep) =

198197 writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ B.encode incDep

199198

200199writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()

@@ -204,13 +203,13 @@ readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)

204203readIncDep transDir incdepName = do

205204 let incDepPath = incDepsDir transDir </> T.unpack incdepName

206205 incDepData <- BS.readFile incDepPath

207− return $ (incdepName, B.decode incDepData)

206+ pure (incdepName, B.decode incDepData)

208207

209208readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)

210209readIncDeps transDir = do

211210 let incDepsPath = incDepsDir transDir

212211 incDepNames <- getDirectoryNames incDepsPath

213− incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)

212+ incDeps <- mapM (readIncDep transDir . T.pack) incDepNames

214213 return $ M.fromList incDeps

215214

216215readSubschemas :: FilePath -> IO Subschemas

@@ -228,9 +227,9 @@ writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping ->

228227writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in

229228 writeBSFileSync sync atPath $ B.encode types

230229

231−readTypeConstructorMapping :: FilePath -> IO (TypeConstructorMapping)

230+readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping

232231readTypeConstructorMapping path = do

233232 let atPath = typeConsPath path

234− liftM B.decode (BS.readFile atPath)

233+ B.decode <$> BS.readFile atPath

235234

236235

src/lib/ProjectM36/TransactionGraph.hs+33−32

@@ -19,6 +19,8 @@ import Data.Binary

1919import ProjectM36.TransactionGraph.Merge

2020import Data.Either (lefts, rights, isRight)

2121import Data.Monoid

22+import Control.Arrow

23+import Data.Maybe

2224

2325{-

2426import Debug.Trace

@@ -69,7 +71,7 @@ transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction

6971transactionForHead headName graph = M.lookup headName (transactionHeadsForGraph graph)

7072

7173headList :: TransactionGraph -> [(HeadName, TransactionId)]

72−headList graph = map (\(k,v) -> (k, transactionId v)) (M.assocs (transactionHeadsForGraph graph))

74+headList graph = map (second transactionId) (M.assocs (transactionHeadsForGraph graph))

7375

7476headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName

7577headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then

@@ -80,23 +82,24 @@ headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchi

8082 matchingTrans = M.filter (transaction ==) heads

8183

8284transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction

83−transactionForId tid graph = if tid == U.nil then

84− Left RootTransactionTraversalError

85− else if S.null matchingTrans then

86− Left $ NoSuchTransactionError tid

87− else

88− Right $ head (S.toList matchingTrans)

85+transactionForId tid graph

86+ | tid == U.nil =

87+ Left RootTransactionTraversalError

88+ | S.null matchingTrans =

89+ Left $ NoSuchTransactionError tid

90+ | otherwise =

91+ Right $ head (S.toList matchingTrans)

8992 where

9093 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)

9194

9295transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)

9396transactionsForIds idSet graph = do

94− transList <- forM (S.toList idSet) ((flip transactionForId) graph)

97+ transList <- forM (S.toList idSet) (`transactionForId` graph)

9598 return (S.fromList transList)

9699

97100isRootTransaction :: Transaction -> TransactionGraph -> Bool

98101isRootTransaction (Transaction _ (TransactionInfo pId _) _) _ = U.null pId

99−isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False

102+isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False

100103

101104-- the first transaction has no parent - all other do have parents- merges have two parents

102105parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

@@ -121,7 +124,7 @@ addBranch newId newBranchName branchPointId graph = do

121124

122125--adds a disconnected transaction to a transaction graph at some head

123126addDisconnectedTransaction :: TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

124−addDisconnectedTransaction newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) schemas') graph

127+addDisconnectedTransaction newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) schemas')

125128

126129

127130addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

@@ -129,7 +132,7 @@ addTransactionToGraph headName newTrans graph = do

129132 let parentIds = transactionParentIds newTrans

130133 childIds = transactionChildIds newTrans

131134 newId = transactionId newTrans

132− validateIds ids = mapM (\i -> transactionForId i graph) (S.toList ids)

135+ validateIds ids = mapM (`transactionForId` graph) (S.toList ids)

133136 addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))

134137 --validate that the parent transactions are in the graph

135138 _ <- validateIds parentIds

@@ -139,15 +142,15 @@ addTransactionToGraph headName newTrans graph = do

139142 Nothing -> pure () -- any headName is OK

140143 Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName))

141144 --validate that the transaction has no children

142− when (not (S.null childIds)) (Left $ NewTransactionMayNotHaveChildrenError newId)

145+ unless (S.null childIds) (Left $ NewTransactionMayNotHaveChildrenError newId)

143146 --validate that the trasaction's id is unique

144147 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))

145148 --update the parent transactions to point to the new transaction

146− parents <- mapM (\tid -> transactionForId tid graph) (S.toList parentIds)

149+ parents <- mapM (`transactionForId` graph) (S.toList parentIds)

147150 let updatedParents = S.map addChildTransaction (S.fromList parents)

148151 updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph))

149152 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)

150− pure (newTrans, (TransactionGraph updatedHeads updatedTransSet))

153+ pure (newTrans, TransactionGraph updatedHeads updatedTransSet)

151154

152155validateGraph :: TransactionGraph -> Maybe [RelationalError]

153156validateGraph graph@(TransactionGraph _ transSet) = do

@@ -276,14 +279,12 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

276279 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

277280 RelationAtom parentTransRel,

278281 BoolAtom $ parentId == transactionId transaction,

279− TextAtom $ case headNameForTransaction transaction graph of

280− Just headName -> headName

281− Nothing -> ""

282+ TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)

282283 ]

283284

284285transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation

285−transactionParentsRelation trans graph = do

286− if isRootTransaction trans graph then do

286+transactionParentsRelation trans graph =

287+ if isRootTransaction trans graph then

287288 mkRelation attrs emptyTupleSet

288289 else do

289290 parentTransSet <- parentTransactions trans graph

@@ -315,7 +316,7 @@ createMergeTransaction newId strat@(UnionPreferMergeStrategy _) graph t2 = creat

315316

316317-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

317318validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

318−validateHeadName headName graph (t1, t2) = do

319+validateHeadName headName graph (t1, t2) =

319320 case transactionForHead headName graph of

320321 Nothing -> Left SelectedHeadMismatchMergeError

321322 Just trans -> if trans /= t1 && trans /= t2 then

@@ -332,21 +333,21 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans trave

332333 Right (TransactionGraph resultHeads traverseSet) -- add filter

333334 --catch root transaction to improve error?

334335 else do

335− currentTransChildren <- liftM S.fromList $ mapM (flip transactionForId origGraph) (S.toList (transactionChildIds currentTrans))

336+ currentTransChildren <- S.fromList <$> mapM (`transactionForId` origGraph) (S.toList (transactionChildIds currentTrans))

336337 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren

337338 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)

338339 childSearches = map searchChild (S.toList searchChildren)

339340 errors = lefts childSearches

340341 pathsFound = rights childSearches

341− realErrors = filter (/= (FailedToFindTransactionError goalid)) errors

342+ realErrors = filter (/= FailedToFindTransactionError goalid) errors

342343 -- report any non-search-related errors

343− when (not (null realErrors)) (Left (head realErrors))

344+ unless (null realErrors) (Left (head realErrors))

344345 -- if no paths found, search the parent

345346 if null pathsFound then

346347 case oneParent currentTrans of

347348 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)

348349 Left err -> Left err

349− Right currentTransParent -> do

350+ Right currentTransParent ->

350351 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)

351352 else -- we found a path

352353 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

@@ -358,19 +359,19 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans trave

358359pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)

359360pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

360361 let targetId = transactionId targetTransaction

361− if transactionId targetTransaction == transactionId currentTransaction then do

362+ if transactionId targetTransaction == transactionId currentTransaction then

362363 Right accumTransSet

363364 else do

364− currentTransChildren <- mapM (flip transactionForId graph) (S.toList (transactionChildIds currentTransaction))

365− if length currentTransChildren == 0 then

365+ currentTransChildren <- mapM (`transactionForId` graph) (S.toList (transactionChildIds currentTransaction))

366+ if null currentTransChildren then

366367 Left (FailedToFindTransactionError targetId)

367368 else do

368369 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren

369370 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)

370371 paths = rights searches

371− if length realErrors > 0 then -- found some real errors

372+ if not (null realErrors) then -- found some real errors

372373 Left (head realErrors)

373− else if length paths == 0 then -- failed to find transaction in all children

374+ else if null paths then -- failed to find transaction in all children

374375 Left (FailedToFindTransactionError targetId)

375376 else --we have some paths!

376377 Right (S.unions paths)

@@ -429,7 +430,7 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

429430

430431 preference <- case strategy of

431432 UnionMergeStrategy -> pure PreferNeither

432− UnionPreferMergeStrategy preferBranch -> do

433+ UnionPreferMergeStrategy preferBranch ->

433434 case transactionForHead preferBranch graph of

434435 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)

435436 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond

@@ -462,7 +463,7 @@ lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case

462463 transactionForId traversedId graph

463464

464465traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId

465−traverseGraph graph currentTid backtrackSteps = foldM (backtrackGraph graph) currentTid backtrackSteps

466+traverseGraph graph = foldM (backtrackGraph graph)

466467

467468backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId

468469-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily

@@ -473,7 +474,7 @@ backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do

473474 Left RootTransactionTraversalError

474475 else do

475476 parentTrans <- transactionForId (head parents) graph

476− if steps == 1 then do

477+ if steps == 1 then

477478 pure (transactionId parentTrans)

478479 else

479480 backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))

src/lib/ProjectM36/TransactionGraph/Merge.hs+4−4

@@ -19,11 +19,11 @@ unionMergeMaps prefer mapA mapB = case prefer of

1919 PreferNeither -> if M.intersection mapA mapB == M.intersection mapA mapB then

2020 pure $ M.union mapA mapB

2121 else

22− Left $ StrategyViolatesComponentMergeError

22+ Left StrategyViolatesComponentMergeError

2323

2424-- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.

2525unionMergeRelation :: MergePreference -> Relation -> Relation -> Either MergeError Relation

26−unionMergeRelation prefer relA relB = case union relA relB of

26+unionMergeRelation prefer relA relB = case relA `union` relB of

2727 Right unionRel -> pure unionRel

2828 Left (AttributeNamesMismatchError _) -> preferredRelVar

2929 Left _ -> Left StrategyViolatesRelationVariableMergeError

@@ -43,7 +43,7 @@ unionMergeRelVars prefer relvarsA relvarsB = do

4343 lookupA = findRel relvarsA

4444 lookupB = findRel relvarsB

4545 case (lookupA, lookupB) of

46− (Just relA, Just relB) -> do

46+ (Just relA, Just relB) ->

4747 unionMergeRelation prefer relA relB

4848 (Nothing, Just relB) -> pure relB

4949 (Just relA, Nothing) -> pure relA

@@ -65,7 +65,7 @@ unionMergeTypeConstructorMapping prefer typesA typesB = do

6565 foldM (\acc name -> do

6666 let findType tcm = case filter (\(t,_) -> TCD.name t == name) tcm of

6767 [] -> Nothing

68− x:[] -> Just x

68+ [x] -> Just x

6969 _ -> error "multiple names matching in TypeConstructorMapping"

7070 lookupA = findType typesA

7171 lookupB = findType typesB

src/lib/ProjectM36/TransactionGraph/Persist.hs+9−8

@@ -18,12 +18,13 @@ import qualified Data.Text as T

1818import Data.Text.Encoding

1919import Control.Monad (foldM)

2020import Data.Either (isRight)

21−import Data.Maybe (catMaybes)

21+import Data.Maybe (mapMaybe)

2222import Control.Exception.Base

2323import qualified Data.Text.IO as TIO

2424import Data.ByteString (ByteString)

2525import Data.Monoid

2626import qualified Crypto.Hash.SHA256 as SHA256

27+import Control.Arrow

2728

2829type LockFileHash = ByteString

2930

@@ -74,7 +75,7 @@ bootstrapDatabaseDir sync dbdir bootstrapGraph = do

7475 digest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (transactionGraphPersist sync dbdir allTransIds bootstrapGraph)

7576 pure (lockFileH, digest)

7677

77−openLockFile :: FilePath -> IO (Handle)

78+openLockFile :: FilePath -> IO Handle

7879openLockFile dbdir = do

7980 lockFileH <- openFile (lockFilePath dbdir) WriteMode

8081 pure lockFileH

@@ -100,7 +101,7 @@ transactionGraphPersist sync destDirectory transIds graph = do

100101-- There was a bug here via #128 because automerge added multiple transactions to the graph but this function used to only write the head transactions from the graph. Automerge creates multiple transactions, so these are now passed in as the second argument.

101102transactionsPersist :: DiskSync -> [TransactionId] -> FilePath -> TransactionGraph -> IO ()

102103transactionsPersist sync transIds destDirectory graphIn = mapM_ writeTrans transIds

103− where writeTrans tid = do

104+ where writeTrans tid =

104105 case transactionForId tid graphIn of

105106 Left err -> error ("writeTransaction: " ++ show err)

106107 Right trans -> writeTransaction sync destDirectory trans

@@ -122,10 +123,10 @@ transactionGraphHeadsPersist sync dbdir graph = do

122123transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,TransactionId)]

123124transactionGraphHeadsLoad dbdir = do

124125 headsData <- readFile (headsPath dbdir)

125− let headsAssocs = map (\l -> let headName:uuidStr:[] = words l in

126+ let headsAssocs = map (\l -> let [headName, uuidStr] = words l in

126127 (headName,uuidStr)

127128 ) (lines headsData)

128− return [(T.pack headName, uuid) | (headName, Just uuid) <- map (\(h,u) -> (h, U.fromString u)) headsAssocs]

129+ return [(T.pack headName, uuid) | (headName, Just uuid) <- map (second U.fromString) headsAssocs]

129130

130131{-

131132load any transactions which are not already part of the incoming transaction graph

@@ -140,7 +141,7 @@ transactionGraphLoad dbdir graphIn mScriptSession = do

140141 case uuidInfo of

141142 Left err -> return $ Left err

142143 Right info -> do

143− let folder = \eitherGraph transId -> case eitherGraph of

144+ let folder eitherGraph transId = case eitherGraph of

144145 Left err -> return $ Left err

145146 Right graph -> readTransactionIfNecessary dbdir transId mScriptSession graph

146147 loadedGraph <- foldM folder (Right graphIn) (map fst info)

@@ -155,7 +156,7 @@ transactionGraphLoad dbdir graphIn mScriptSession = do

155156if the transaction with the TransactionId argument is not yet part of the graph, then read the transaction and add it - this does not update the heads

156157-}

157158readTransactionIfNecessary :: FilePath -> TransactionId -> Maybe ScriptSession -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)

158−readTransactionIfNecessary dbdir transId mScriptSession graphIn = do

159+readTransactionIfNecessary dbdir transId mScriptSession graphIn =

159160 if isRight $ transactionForId transId graphIn then

160161 --the transaction is already known and loaded- done

161162 return $ Right graphIn

@@ -182,7 +183,7 @@ readGraphTransactionIdFileDigest dbdir = do

182183readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, [TransactionId])])

183184readGraphTransactionIdFile dbdir = do

184185 --read in all transactions' uuids

185− let grapher line = let tids = catMaybes (map U.fromText (T.words line)) in

186+ let grapher line = let tids = mapMaybe U.fromText (T.words line) in

186187 (head tids, tail tids)

187188 --warning: uses lazy IO

188189 graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

src/lib/ProjectM36/TransactionGraph/Show/Dot.hs+1−1

@@ -10,7 +10,7 @@ graphAsDot (TransactionGraph heads transSet) = "digraph {" ++ dot ++ headInfo ++

1010 where

1111 dot = S.foldr transactionAsDot "" transSet

1212 transactionAsDot trans acc = acc ++ childArrows trans ++ parentArrows trans

13− arrows trans idSet = S.foldr (\c acc' -> acc' ++ oneArrow trans c) "" idSet

13+ arrows trans = S.foldr (\c acc' -> acc' ++ oneArrow trans c) ""

1414 childArrows trans = arrows trans (transactionChildIds trans)

1515 parentArrows trans = arrows trans (transactionParentIds trans)

1616 transLabel t = tidLabel (transactionId t)

src/lib/ProjectM36/Tuple.hs+15−14

@@ -11,6 +11,8 @@ import qualified Data.Set as S

1111import qualified Data.Vector as V

1212import Data.Either (rights)

1313import Control.Monad

14+import Control.Arrow

15+import Data.Maybe

1416

1517emptyTuple :: RelationTuple

1618emptyTuple = RelationTuple V.empty V.empty

@@ -25,7 +27,7 @@ tupleAttributes :: RelationTuple -> Attributes

2527tupleAttributes (RelationTuple tupAttrs _) = tupAttrs

2628

2729tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]

28−tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (\(k,v) -> (attributeName k, v)) (V.zip attrVec tupVec)

30+tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)

2931

3032-- return atoms in some arbitrary but consistent key order

3133tupleAtoms :: RelationTuple -> V.Vector Atom

@@ -56,10 +58,9 @@ vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNa

5658 else

5759 Right $ V.map mapper attrNameVec

5860 where

59− unknownAttrNames = V.filter ((flip V.notElem) (attributeNames attrs)) attrNameVec

60− mapper attrName = case V.elemIndex attrName (V.map attributeName attrs) of

61− Nothing -> error "logic failure in vectorIndicesForAttributeNames"

62− Just index -> index

61+ unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec

62+ mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (V.map attributeName attrs))

63+

6364

6465relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation

6566relationForAttributeName attrName tuple = do

@@ -77,10 +78,10 @@ tupleRenameAttribute oldattr newattr (RelationTuple tupAttrs tupVec) = RelationT

7778 newAttrs = renameAttributes oldattr newattr tupAttrs

7879

7980mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple

80−mkRelationTuple attrs atoms = RelationTuple attrs atoms

81+mkRelationTuple = RelationTuple

8182

8283mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple]

83−mkRelationTuples attrs atomsVec = map mapper atomsVec

84+mkRelationTuples attrs = map mapper

8485 where

8586 mapper = mkRelationTuple attrs

8687

@@ -92,7 +93,7 @@ mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (\attrName -> attrMa

9293

9394--return error if attribute names match but their types do not

9495singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]

95−singleTupleSetJoin joinAttrs tup tupSet = do

96+singleTupleSetJoin joinAttrs tup tupSet =

9697 foldM tupleJoiner [] (asList tupSet)

9798 where

9899 tupleJoiner :: [RelationTuple] -> RelationTuple -> Either RelationalError [RelationTuple]

@@ -114,12 +115,12 @@ singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either Relati

114115singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if

115116 V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2

116117 then

117− return $ Nothing

118+ return Nothing

118119 else

119120 return $ Just $ RelationTuple joinedAttrs newVec

120121 where

121122 keysIntersection = V.map attributeName attrsIntersection

122− attrsIntersection = V.filter (flip V.elem $ tupAttrs1) tupAttrs2

123+ attrsIntersection = V.filter (`V.elem` tupAttrs1) tupAttrs2

123124 newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs

124125 --search both tuples for the attribute

125126 findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]

@@ -174,15 +175,15 @@ tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec

174175 newTupVec = indexFilter (tupleAtoms tuple1)

175176

176177-- | An optimized form of tuple update which updates vectors efficiently.

177−updateTupleWithAtoms :: (M.Map AttributeName Atom) -> RelationTuple -> RelationTuple

178+updateTupleWithAtoms :: M.Map AttributeName Atom -> RelationTuple -> RelationTuple

178179updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec

179180 where

180181 updateKeysSet = M.keysSet updateMap

181182 updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)

182183 newVec = V.update tupVec updateVec

183− updateVec = V.map (\(index, attr) -> (index, updateMap M.! (attributeName attr))) updateKeysIVec

184+ updateVec = V.map (\(index, attr) -> (index, updateMap M.! attributeName attr)) updateKeysIVec

184185

185−tupleToMap :: RelationTuple -> (M.Map AttributeName Atom)

186+tupleToMap :: RelationTuple -> M.Map AttributeName Atom

186187tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList

187188 where

188189 assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)

@@ -201,7 +202,7 @@ verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs

201202reorderTuple :: Attributes -> RelationTuple -> RelationTuple

202203reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

203204 tupIn

204− else do

205+ else

205206 RelationTuple attrs (V.map mapper attrs)

206207 where

207208 mapper attr = case atomForAttributeName (attributeName attr) tupIn of

src/lib/ProjectM36/TupleSet.hs+4−4

@@ -18,10 +18,10 @@ singletonTupleSet = RelationTupleSet [emptyTuple]

1818verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet

1919verifyTupleSet attrs tupleSet = do

2020 --check that all tuples have the same attributes and that the atom types match

21− let tupleList = (map (verifyTuple attrs) (asList tupleSet)) `P.using` P.parListChunk chunkSize P.r0

22− chunkSize = ((length . asList) tupleSet) `div` 24

21+ let tupleList = map (verifyTuple attrs) (asList tupleSet) `P.using` P.parListChunk chunkSize P.r0

22+ chunkSize = (length . asList) tupleSet `div` 24

2323 --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet)

24− if length (lefts tupleList) > 0 then

24+ if not (null (lefts tupleList)) then

2525 Left $ head (lefts tupleList)

2626 else

2727 return $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList)

@@ -30,4 +30,4 @@ mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTu

3030mkTupleSet attrs tuples = verifyTupleSet attrs (RelationTupleSet tuples)

3131

3232mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet

33−mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (\atomList -> mkRelationTuple attrs (V.fromList atomList)) atomMatrix

33+mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (mkRelationTuple attrs . V.fromList) atomMatrix

src/lib/ProjectM36/WebSocketServer.hsdeleted−14

@@ -1,14 +0,0 @@

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−

src/lib/ProjectM36/Win32Handle.hs+1−1

@@ -41,7 +41,7 @@ withHandleToHANDLE haskell_handle action =

4141

4242 -- Get the FD from the algebraic data type

4343#if __GLASGOW_HASKELL__ < 612

44− fd <- fmap haFD $ readMVar write_handle_mvar

44+ fd <- haFD <$> readMVar write_handle_mvar

4545#else

4646 --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev)

4747 Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar

test/IsomorphicSchema.hs+2−2

@@ -65,8 +65,8 @@ testIsoRestrict :: Test

6565testIsoRestrict = TestCase $ do

6666 -- create a emp relation which is restricted into two boss, nonboss rel vars

6767 -- the virtual schema has an employee

68− let empattrs = (A.attributesFromList [Attribute "name" TextAtomType,

69− Attribute "boss" TextAtomType])

68+ let empattrs = A.attributesFromList [Attribute "name" TextAtomType,

69+ Attribute "boss" TextAtomType]

7070 emprel <- assertEither $ mkRelationFromList empattrs

7171 [[TextAtom "Steve", TextAtom ""],

7272 [TextAtom "Cindy", TextAtom "Steve"],

test/MultiProcessDatabaseAccess.hs+1−1

@@ -23,7 +23,7 @@ testList :: Test

2323testList = TestList [testMultipleProcessAccess]

2424

2525testMultipleProcessAccess :: Test

26−testMultipleProcessAccess = TestCase $ do

26+testMultipleProcessAccess = TestCase $

2727 withSystemTempDirectory "pm36" $ \tmpdir -> do

2828 let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []

2929 master = "master"

test/Relation/Atomable.hs+2−1

@@ -13,6 +13,7 @@ import Data.Time.Calendar (fromGregorian)

1313import Data.Text

1414import qualified Data.Map as M

1515

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

1617data Test1T = Test1C Int

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

1819

@@ -108,7 +109,7 @@ testADT5 = TestCase $ do

108109 assertEqual "record-based ADT" example (fromAtom (toAtom example))

109110

110111checkExecuteDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO ()

111−checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextExpr sessionId dbconn expr >>= either (\err -> assertFailure (show err)) (const (pure ()))

112+checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextExpr sessionId dbconn expr >>= either (assertFailure . show) (const (pure ()))

112113

113114testListInstance :: Test

114115testListInstance = TestCase $ do

test/Relation/Basic.hs+1−1

@@ -50,7 +50,7 @@ validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupSet)

5050

5151validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation

5252validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple acc ->

53− if (tupleAttributes tuple) == attrs && tupleAtomCheck tuple then

53+ if tupleAttributes tuple == attrs && tupleAtomCheck tuple then

5454 acc

5555 else

5656 Left $ TupleAttributeTypeMismatchError A.emptyAttributes

test/Relation/Export/CSV.hs+4−4

@@ -22,11 +22,11 @@ testCSVExport = TestCase $ do

2222 [TextAtom "S9", TextAtom "Perry", IntAtom 170, TextAtom "Londonderry"],

2323 [TextAtom "S8", TextAtom "Mike", IntAtom 150, TextAtom "Boston"]]

2424 case relOrErr of

25− Left err -> assertFailure $ "export relation creation failure: " ++ (show err)

26− Right rel -> do

25+ Left err -> assertFailure $ "export relation creation failure: " ++ show err

26+ Right rel ->

2727 case relationAsCSV rel of

28− Left err -> assertFailure $ "export failed: " ++ (show err)

28+ Left err -> assertFailure $ "export failed: " ++ show err

2929 Right csvData -> case csvAsRelation csvData attrs of -- import csv data back to relation

30− Left err -> assertFailure $ "re-import failed: " ++ (show err)

30+ Left err -> assertFailure $ "re-import failed: " ++ show err

3131 Right rel' -> assertEqual "relation CSV comparison" rel rel'

3232

test/Server/Main.hs+2−3

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

5050 notificationTestMVar <- newEmptyMVar

5151 eTestConn <- testConnection serverAddress notificationTestMVar

5252 case eTestConn of

53− Left err -> putStrLn (show err) >> exitFailure

53+ Left err -> print err >> exitFailure

5454 Right (session, testConn) -> do

5555 tcounts <- runTestTT (testList session testConn notificationTestMVar)

5656 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

@@ -121,8 +121,7 @@ testDatabaseContextExpr sessionId conn = TestCase $ do

121121 Right rel -> assertEqual "dbcontext definition failed" expected (Right rel)

122122

123123testGraphExpr :: SessionId -> Connection -> Test

124−testGraphExpr sessionId conn = TestCase $ do

125− executeGraphExpr sessionId conn (JumpToHead "master") >>= eitherFail

124+testGraphExpr sessionId conn = TestCase (executeGraphExpr sessionId conn (JumpToHead "master") >>= eitherFail)

126125

127126testTypeForRelationalExpr :: SessionId -> Connection -> Test

128127testTypeForRelationalExpr sessionId conn = TestCase $ do

test/Server/WebSocket.hs+4−5

@@ -1,5 +1,4 @@

11-- test the websocket server

2−

32import Test.HUnit

43import qualified Network.WebSockets as WS

54import ProjectM36.Server.WebSocket

@@ -46,14 +45,14 @@ data TestException = WaitForSocketListenException

4645instance Exception TestException

4746

4847waitForListenSocket :: Int -> PortNumber -> IO ()

49−waitForListenSocket secondsToTry port = do

48+waitForListenSocket secondsToTry port =

5049 if secondsToTry <= 0 then

5150 throw WaitForSocketListenException

5251 else do

5352 hostaddr <- inet_addr "127.0.0.1"

5453 sock <- socket AF_INET Stream defaultProtocol

5554 let handler :: IOException -> IO ()

56− handler = \_ -> do

55+ handler _ = do

5756 threadDelay 1000000

5857 waitForListenSocket (secondsToTry - 1) port

5958 catch (connect sock (SockAddrInet port hostaddr)) handler

@@ -69,11 +68,11 @@ testList port dbName = TestList $ map (\f -> f port dbName) [testBasicConnection

6968 testTutorialD]

7069

7170basicConnection :: PortNumber -> WS.ClientApp () -> IO ()

72−basicConnection port block = WS.runClient "127.0.0.1" (fromIntegral port) "/" block

71+basicConnection port = WS.runClient "127.0.0.1" (fromIntegral port) "/"

7372

7473basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO ()

7574basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do

76− WS.sendTextData conn ("connectdb:" `append` (pack dbname))

75+ WS.sendTextData conn ("connectdb:" `append` pack dbname)

7776 block conn)

7877

7978testBasicConnection :: PortNumber -> DatabaseName -> Test

test/TransactionGraph/Automerge.hs+2−1

@@ -10,6 +10,7 @@ import System.IO.Temp

1010import System.FilePath

1111import Control.Exception.Base

1212

13+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

1314main :: IO ()

1415main = do

1516 tcounts <- runTestTT testList

@@ -42,7 +43,7 @@ testAutomergeSuccess = TestCase $ do

4243

4344 --validate that both tuples are now in the head transaction

4445

45− let predi key = eqAttr key

46+ let predi = eqAttr

4647 eqAttr key = AttributeEqualityPredicate "s#" (NakedAtomExpr (TextAtom key))

4748 result <- checkEither $ executeRelationalExpr sessionPastId conn (Project (AttributeNames S.empty) (Restrict (predi "S6") (RelationVariable "s" ())))

4849 assertEqual "new S6" relationTrue result

test/TransactionGraph/Merge.hs+7−8

@@ -17,9 +17,12 @@ import Data.Word

1717import qualified Data.UUID as U

1818import qualified Data.Set as S

1919import qualified Data.Map as M

20+import Data.Maybe

2021

2122import Control.Monad.State hiding (join)

2223

24+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

25+

2326main :: IO ()

2427main = do

2528 tcounts <- runTestTT testList

@@ -49,9 +52,7 @@ createTrans tid info ctx = Transaction tid info (Schemas ctx M.empty)

4952basicTransactionGraph :: IO TransactionGraph

5053basicTransactionGraph = do

5154 let bsGraph = bootstrapTransactionGraph uuidRoot DBC.basicDatabaseContext

52− rootTrans = case transactionForHead "master" bsGraph of

53− Just trans -> trans

54− Nothing -> error "bonk"

55+ rootTrans = fromMaybe (error "bonk") (transactionForHead "master" bsGraph)

5556 uuidA = fakeUUID 10

5657 uuidB = fakeUUID 11

5758 uuidRoot = fakeUUID 1

@@ -66,9 +67,7 @@ addTransaction headName transaction graph = case addTransactionToGraph headName

6667 Right (t,g) -> pure (t,g)

6768

6869fakeUUID :: Word8 -> TransactionId

69−fakeUUID x = case U.fromByteString (BS.concat (replicate 4 w32)) of

70− Nothing -> error "impossible uuid"

71− Just u -> u

70+fakeUUID x = fromMaybe (error "impossible uuid") (U.fromByteString (BS.concat (replicate 4 w32)))

7271 where w32 = BS.pack (replicate 4 x)

7372

7473assertEither :: (Show a) => Either a b -> IO b

@@ -131,7 +130,7 @@ testSubGraphToFirstAncestorMoreTransactions = TestCase $ do

131130 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')

132131

133132 --retrieve subgraph

134− let subGraphHeads = M.filter (\t -> elem (transactionId t) [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'')

133+ let subGraphHeads = M.filter (\t -> transactionId t `elem` [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'')

135134 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph'' subGraphHeads branchATrans' branchBTrans' S.empty

136135 --verify that the subgraph includes both the heads and the common ancestor

137136 let expectedTransSet = S.fromList (map fakeUUID [1,3,4])

@@ -181,7 +180,7 @@ testUnionPreferMergeStrategy = TestCase $ do

181180 let merged = mergeTransactions (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''

182181 case merged of

183182 Left err -> assertFailure ("expected merge success: " ++ show err)

184− Right (discon, _) -> do

183+ Right (discon, _) ->

185184 assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)))

186185

187186-- try various individual component conflicts and check for merge failure

test/TransactionGraph/Persist.hs+1−2

@@ -1,4 +1,3 @@

1−{-# LANGUAGE LambdaCase #-}

21import Test.HUnit

32import ProjectM36.Base

43import ProjectM36.Persist (DiskSync(NoDiskSync))

@@ -45,7 +44,7 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

4544 _ <- bootstrapDatabaseDir NoDiskSync dbdir graph

4645 case transactionForHead "master" graph of

4746 Nothing -> assertFailure "Failed to retrieve head transaction for master branch."

48− Just headTrans -> do

47+ Just headTrans ->

4948 case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) "x:=s" of

5049 Left err -> assertFailure (show err)

5150 Right context' -> do

test/TutorialD/Interpreter.hs+9−9

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

4444 ("x:=relation{a Int}{}", mkRelation simpleAAttributes emptyTupleSet),

4545 ("x:=relation{c Int}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),

4646 ("y:=relation{b Int, c Int}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),

47− ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [(RelationTuple simpleCAttributes) (V.fromList [TextAtom "spam", IntAtom 5])]),

47+ ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntAtom 5])]),

4848 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),

4949 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),

5050 ("x:=relation{}{}", Right relationFalse),

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

8787 statusAtom <- atomForAttributeName "status" tuple

8888 cityAtom <- atomForAttributeName "city" tuple

8989 if cityAtom == TextAtom "Paris" then

90− Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom ((castInt statusAtom) + 10))) tuple

90+ Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom (castInt statusAtom + 10))) tuple

9191 else Right tuple) suppliersRel

9292 dateExampleRelTests = [("x:=s where true", Right suppliersRel),

9393 ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),

@@ -113,10 +113,10 @@ main = do

113113 ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),

114114 ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"]]),

115115 --test "all but" attribute inversion syntax

116− ("x:=s{all but s#} = s{city,sname,status}", Right $ relationTrue),

116+ ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),

117117 --test key syntax

118118 ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")),

119− ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right $ relationTrue),

119+ ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right relationTrue),

120120 --test binary bytestring data type

121121 ("x:=relation{tuple{y makeByteString(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),

122122 --test Maybe Text

@@ -194,7 +194,7 @@ transactionJumpTest = TestCase $ do

194194transactionBranchTest :: Test

195195transactionBranchTest = TestCase $ do

196196 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

197− mapM_ (\x -> x >>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),

197+ mapM_ (>>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),

198198 executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),

199199 commit sessionId dbconn,

200200 executeGraphExpr sessionId dbconn (JumpToHead "master"),

@@ -244,7 +244,7 @@ inclusionDependencies _ = error "remote connection used"

244244testNotification :: Test

245245testNotification = TestCase $ do

246246 notifmvar <- newEmptyMVar

247− let notifCallback mvar = \_ _ -> putMVar mvar ()

247+ let notifCallback mvar _ _ = putMVar mvar ()

248248 relvarx = RelationVariable "x" ()

249249 (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)

250250 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail

@@ -381,9 +381,9 @@ testRelationalExprStateTupleElems = TestCase $ do

381381 --check subexpression evaluation in restriction predicate

382382 -- "rv1 where ((rv2 where val=@test) {})"

383383 let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())

384− mainExpr subexpr = (Restrict

385− (RelationalExprPredicate

386− (Project AN.empty subexpr)) (RelationVariable "rv1" ()))

384+ mainExpr subexpr = Restrict

385+ (RelationalExprPredicate

386+ (Project AN.empty subexpr)) (RelationVariable "rv1" ())

387387 eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)

388388 let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntAtomType]) [[IntAtom 1]]

389389 assertEqual "validate sub-expression attribute" expectedRel2 eRv2

test/TutorialD/Interpreter/AtomFunctionScript.hs+1

@@ -8,6 +8,7 @@ import ProjectM36.DataTypes.Maybe

88import qualified Data.Vector as V

99import qualified Data.Map as M

1010

11+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

1112main :: IO ()

1213main = do

1314 tcounts <- runTestTT (TestList [testBasicAtomFunction,

test/TutorialD/Interpreter/Import/TutorialD.hs+1−1

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

1212 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

1313

1414testTutdImport :: Test

15−testTutdImport = TestCase $ do

15+testTutdImport = TestCase $

1616 withSystemTempFile "m.tutd" $ \tempPath handle -> do

1717 hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}"

1818 hClose handle

test/persistent-driver/test.hsdeleted−174

@@ -1,174 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE QuasiQuotes #-}

3−{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE EmptyDataDecls #-}

6−{-# LANGUAGE TypeSynonymInstances #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9−{-# LANGUAGE FlexibleInstances #-}

10−import Test.HUnit

11−import Database.Persist.ProjectM36

12−import ProjectM36.Client

13−import qualified ProjectM36.Client as C

14−import System.Exit

15−import Database.Persist

16−import Database.Persist.TH

17−import Language.Haskell.TH.Syntax

18−import Control.Monad.Reader

19−import Control.Exception (throwIO)

20−

21−let projectM36PersistSettings = mkPersistSettings (ConT ''ProjectM36Backend)

22− in

23− share [mkPersist projectM36PersistSettings] [persistLowerCase|

24−Person

25− name String Eq

26− age Int

27− UniqueName name

28− deriving Show

29−|]

30−

31−testList :: Test

32−testList = TestList $ map mkInProcessTest [testGetBy, testDelete, testUpdate, testCount, testSelect, testSelectKeys]

33−

34−main :: IO ()

35−main = do

36− tcounts <- runTestTT testList

37− if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

38−

39−inProcSettings :: ConnectionInfo

40−inProcSettings = InProcessConnectionInfo NoPersistence emptyNotificationCallback []

41−

42−defPersonRel :: SessionId -> Connection -> IO ()

43−defPersonRel sessionId conn = do

44− let textTypCons = PrimitiveTypeConstructor "Text" TextAtomType

45− intTypCons = PrimitiveTypeConstructor "Int" IntAtomType

46−

47− maybeErr <- C.executeDatabaseContextExpr sessionId conn (Define "person" [

48− AttributeAndTypeNameExpr "name" textTypCons (),

49− AttributeAndTypeNameExpr "age" intTypCons (),

50− AttributeAndTypeNameExpr "id" textTypCons ()])

51− case maybeErr of

52− Nothing -> return ()

53− Just err -> assertFailure $ "defPersonRel" ++ show err

54−

55−mkInProcessTest :: ReaderT ProjectM36Backend IO () -> Test

56−mkInProcessTest m = TestCase $ do

57− withProjectM36Conn inProcSettings $ runProjectM36Conn $ do

58− (sessionId, conn) <- ask

59− liftIO (defPersonRel sessionId conn)

60− m

61−

62−entityFromMaybe :: (PersistEntity val) => Maybe (Entity val) -> IO (Entity val)

63−entityFromMaybe may = case may of

64− Nothing -> assertFailure "expected entity not found" >> throwIO (PersistError "not found")

65− Just ent -> return ent

66−

67−valFromMaybe :: (PersistEntity val) => Maybe val -> IO val

68−valFromMaybe may = case may of

69− Nothing -> assertFailure "expected value not found" >> throwIO (PersistError "not found")

70− Just val -> return val

71−

72−-- insert a person, getBy to check he is there

73−testGetBy :: ReaderT ProjectM36Backend IO ()

74−testGetBy = do

75− let name = "Michael"

76− age = 26

77− _ <- insert $ Person name age

78− michael <- getBy $ UniqueName name

79− michael' <- liftIO $ entityFromMaybe michael

80− liftIO $ assertEqual "name equality" name (personName $ entityVal michael')

81− liftIO $ assertEqual "age equality" age (personAge $ entityVal michael')

82− return ()

83−

84−--insert two people, delete one, check one remains

85−testDelete :: ReaderT ProjectM36Backend IO ()

86−testDelete = do

87− let name1 = "Michael"

88− age1 = 26

89− name2 = "John"

90− age2 = 30

91− _ <- insert $ Person name1 age1

92− m2 <- insert $ Person name2 age2

93− deleteBy $ UniqueName name1 --delete michael

94− nom1 <- getBy $ UniqueName name1

95− --check that m1 was deleted

96− case nom1 of

97− Just _ -> liftIO $ assertFailure "deleteBy failure"

98− Nothing -> return ()

99− --check that m2 still exists

100− m2check <- getBy $ UniqueName name2

101− case m2check of

102− Nothing -> liftIO $ assertFailure "deleteBy failure2"

103− Just _ -> return ()

104− --delete m2

105− deleteWhere [PersonName ==. name2]

106− m2del <- get m2

107− case m2del of

108− Just _ -> liftIO $ assertFailure "deleteBy failure m2"

109− Nothing -> return ()

110− return ()

111−

112−--insert two people, update one-at-a-time, confirm update

113−testUpdate :: ReaderT ProjectM36Backend IO ()

114−testUpdate = do

115− let name1 = "Michael"

116− age1 = 26

117− name2 = "John"

118− age2 = 30

119− name3 = "Dracula"

120− m1 <- insert $ Person name1 age1

121− m2 <- insert $ Person name2 age2

122− update m1 [PersonAge =. 35] -- update m1's age

123− updateWhere [PersonName ==. name2] [PersonName =. name3] --update m2's name

124− m1up <- get m1

125− m1up' <- liftIO $ valFromMaybe m1up

126− m2up <- get m2

127− m2up' <- liftIO $ valFromMaybe m2up

128− liftIO $ assertEqual "m1 update" name1 (personName m1up')

129− liftIO $ assertEqual "m1 update" 35 (personAge m1up')

130− liftIO $ assertEqual "m2 update" name3 (personName m2up')

131− liftIO $ assertEqual "m2 update" age2 (personAge m2up')

132− return ()

133−

134−testCount :: ReaderT ProjectM36Backend IO ()

135−testCount = do

136− let name1 = "Michael"

137− age1 = 26

138− name2 = "John"

139− age2 = 30

140− _ <- insert $ Person name1 age1

141− _ <- insert $ Person name2 age2

142− c1 <- count [PersonAge ==. 26]

143− liftIO $ assertEqual "count age" 1 c1

144− c2 <- count [PersonAge !=. 400]

145− liftIO $ assertEqual "count age2" 2 c2

146−

147−--currently, selection only supports filter/restriction and not sorting

148−--insert two people, test that restriction locates each and both

149−testSelect :: ReaderT ProjectM36Backend IO ()

150−testSelect = do

151− let name1 = "Michael"

152− age1 = 26

153− name2 = "John"

154− age2 = 30

155− _ <- insert $ Person name1 age1

156− _ <- insert $ Person name2 age2

157− name1List <- selectList [PersonName ==. name1] []

158− liftIO $ assertEqual "select name1 len" 1 (length name1List)

159− liftIO $ assertEqual "select name1 val" name1 ((personName . entityVal . head) name1List)

160− namesList <- selectList [] []

161− liftIO $ assertEqual "select names len" 2 (length (namesList :: [Entity Person]))

162−

163−testSelectKeys :: ReaderT ProjectM36Backend IO ()

164−testSelectKeys = do

165− let name1 = "Michael"

166− age1 = 26

167− name2 = "John"

168− age2 = 30

169− _ <- insert $ Person name1 age1

170− m2 <- insert $ Person name2 age2

171− keysList <- selectKeysList [PersonAge ==. age2] []

172− liftIO $ assertEqual "select keysList len" 1 (length keysList)

173− liftIO $ assertEqual "select keysList val" m2 (head keysList)

174−