eb07d28 · project-m36 · git.iko.soy

src/bin/ProjectM36/Server/WebSocket.hs+2−1

compare with master

unifiedsplit

@@ -22,6 +22,7 @@ import Data.Attoparsec.Text

22import Control.Applicative

23import Text.Megaparsec.Error

24import Data.Functor

25+import Data.Either (fromRight)

25

26

26#if MIN_VERSION_megaparsec(7,0,0)

27#if MIN_VERSION_megaparsec(7,0,0)

27import Data.List.NonEmpty as NE

28import Data.List.NonEmpty as NE

@@ -117,7 +118,7 @@ promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

117promptInfo sessionId conn = do

118promptInfo sessionId conn = do

118 eHeadName <- headName sessionId conn

119 eHeadName <- headName sessionId conn

119 eSchemaName <- currentSchemaName sessionId conn

120 eSchemaName <- currentSchemaName sessionId conn

120− pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)

121+ pure (fromRight "<unknown>" eHeadName, fromRight "<no schema>" eSchemaName)

121

122

122sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()

123sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()

123sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

124sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

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

@@ -34,6 +34,7 @@ import Data.Monoid

34import Data.List (isPrefixOf)

35import Control.Exception

36import System.Exit

37+import Data.Either (fromRight)

37

38

38{-

39{-

39context ops are read-only operations which only operate on the database context (relvars and constraints)

40context ops are read-only operations which only operate on the database context (relvars and constraints)

@@ -77,7 +78,7 @@ safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <*

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

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

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

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

79 where

80 where

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

81+ transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName

81

82

82parseTutorialD :: T.Text -> Either ParserError ParsedOperation

83parseTutorialD :: T.Text -> Either ParserError ParsedOperation

83parseTutorialD = parse interpreterParserP ""

84parseTutorialD = parse interpreterParserP ""

src/lib/ProjectM36/Attribute.hs+6−6

@@ -87,12 +87,12 @@ joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length

87 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1

88-}

89joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

90−joinAttributes attrs1 attrs2 =

90+joinAttributes attrs1 attrs2

91− if S.size overlappingNames == 0 then -- fast path, no overlapping names

91+ | S.size overlappingNames == 0 = -- fast path, no overlapping names

92 pure (concated id)

93− else if attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 then -- check that atomtypes match

93+ | attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 = -- that atomtypes match

94 pure (concated vectorUniqueify)

95− else

95+ | otherwise =

96 --special handling to validate that overlapping names have the same atom types

97 Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrs1))

98 where

@@ -111,7 +111,7 @@ member :: Attribute -> Attributes -> Bool

111member attr attrs = HS.member attr (attributesSet attrs)

112

113deleteAttributeName :: AttributeName -> Attributes -> Attributes

114−deleteAttributeName attrName attrs = deleteAttributeNames (S.singleton attrName) attrs

114+deleteAttributeName attrName = deleteAttributeNames (S.singleton attrName)

115

116deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes

117deleteAttributeNames attrNames attrs = Attributes {

@@ -215,7 +215,7 @@ attributesDifference attrsA attrsB =

215 hset = HS.difference setA setB <> HS.difference setB setA

216 setA = attributesSet attrsA

217 setB = attributesSet attrsB

218− vec = V.filter (\attr -> HS.member attr hset) (attributesVec attrsA <> attributesVec attrsB)

218+ vec = V.filter (`HS.member` hset) (attributesVec attrsA <> attributesVec attrsB)

219

220vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a

221vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn

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

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

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies, DeriveFoldable, DeriveTraversable #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies #-}

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

3

4module ProjectM36.Base where

@@ -102,7 +102,7 @@ instance Hashable Attribute where

102type AttributesHash = Int

103

104-- | 'Attributes' represent the head of a relation.

105−data Attributes = Attributes {

105+newtype Attributes = Attributes {

106 attributesVec :: V.Vector Attribute

107 --,attributesSet :: HS.HashSet Attribute --compare with this generated in heap profile and benchmarks

108 }

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

@@ -244,8 +244,8 @@ relMap mapper (Relation attrs tupleSet) =

244

245relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

246relMogrify mapper newAttributes (Relation _ tupSet) = do

247− newTuples <- mapM (\tup ->

248− reorderTuple newAttributes <$> mapper tup) (asList tupSet)

247+ newTuples <- mapM (fmap (reorderTuple newAttributes) . mapper) (asList tupSet)

248+

249 mkRelationFromTuples newAttributes newTuples

250

251relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a

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

@@ -177,7 +177,7 @@ fullOptimizeGraphRefRelationalExpr expr = do

177optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

178optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

179

180−optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs{}) = pure e

180+optimizeGraphRefRelationalExpr e@MakeRelationFromExprs{} = pure e

181

182optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e

183

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

@@ -384,7 +384,7 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav

384 else do

385 currentTransChildren <- childTransactions currentTrans' origGraph

386 let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren

387− searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)

387+ searchChild start' = pathToTransaction origGraph start' goalTrans (S.insert currentTrans' traverseSet)

388 childSearches = map searchChild (S.toList searchChildren)

389 errors = lefts childSearches

390 pathsFound = rights childSearches