f42ee21 · project-m36 · git.iko.soy

git.iko.soy/project-m36

add basic atom functions: count, min, max

commitf42ee21a0957742a7f69a68953dcced90329e3af authorAgentM <agentm@themactionfaction.com> dateSat 30 May 2015, 12:00 (11 years ago) parent7bfa060

8 files changed+157−71

compare with master

unifiedsplit

ProjectM36/AtomFunction.hs+37 ProjectM36/Base.hs+2−6 ProjectM36/Relation.hs+17−3 ProjectM36/RelationalExpression.hs+37−46 ProjectM36/Tuple.hs+13−3 TutorialD/Interpreter.hs+36−10 project-m36.cabal+1 test/TutorialD/Interpreter.hs+14−3

ProjectM36/AtomFunction.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.AtomFunction where

3+import ProjectM36.Base

4+import ProjectM36.Error

5+import qualified ProjectM36.Attribute as A

6+import qualified Data.HashSet as HS

7+import qualified Data.Vector as V

9+foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

10+foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]

11+

12+atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

13+atomFunctionForName funcName funcSet = if HS.null foundFunc then

14+ Left $ NoSuchTupleExprFunctionError funcName

15+ else

16+ Right $ head $ HS.toList foundFunc

17+ where

18+ foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet

19+

20+--determine if two types are equal or compatible

21+atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

22+atomTypeVerify AnyAtomType x = Right x

23+atomTypeVerify x AnyAtomType = Right x

24+atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

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

26+ name2 = A.attributeName attr2 in

27+ if notElem "_" [name1, name2] && name1 /= name2 then

28+ Left $ AtomTypeMismatchError x y

29+ else

30+ atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)

31+ return x

32+atomTypeVerify x y = if x == y then

33+ Right x

34+ else

35+ Left $ AtomTypeMismatchError x y

36+

37+

ProjectM36/Base.hs+2−6

@@ -111,11 +111,7 @@ data RelationalExpr where

111111 Restrict :: RestrictionPredicateExpr -> RelationalExpr -> RelationalExpr

112112 Equals :: RelationalExpr -> RelationalExpr -> RelationalExpr

113113 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

114−{- maybe break this into multiple steps:

115−1. check relational types for match (attribute counts) (typechecking step

116−2. create an execution plan (another system of nodes, another GADT)

117−3. execute the plan

118−-}

114+ --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

119115 deriving (Show,Eq)

120116

121117data DatabaseContext = DatabaseContext {

@@ -214,7 +210,7 @@ type AtomFunctionName = StringType

214210

215211data AtomFunction = AtomFunction {

216212 atomFuncName :: AtomFunctionName,

217− atomFuncType :: [AtomType],

213+ atomFuncType :: [AtomType],

218214 atomFunc :: [Atom] -> Atom

219215 }

220216

ProjectM36/Relation.hs+17−3

@@ -151,7 +151,7 @@ group groupAttrNames newAttrName rel = do

151151 newAttrs = A.addAttribute groupAttr (attributesForNames nonGroupAttrNames rel)

152152 groupAttr = Attribute newAttrName (RelationAtomType (attributesForNames groupAttrNames rel))

153153 nonGroupAttrNames = A.nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)

154− mogrifier tupIn = tupleExtend (traceShowId tupIn) (matchingRelTuple tupIn)

154+ mogrifier tupIn = tupleExtend tupIn (matchingRelTuple tupIn)

155155 matchingRelTuple tupIn = case imageRelationFor tupIn rel of

156156 Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))

157157 Left _ -> undefined

@@ -277,7 +277,21 @@ matrixRelation attributeCount tupleCount = do

277277 tupleSet = HS.fromList $ map (\c -> tuple c) [0 .. tupleCount]

278278 mkRelation attrs tupleSet

279279

280+--used by sum atom function

281+relationSum :: Relation -> Atom

282+relationSum relIn = IntAtom $ relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn

283+ where

284+ newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0

280285

286+relationCount :: Relation -> Atom

287+relationCount relIn = IntAtom $ relFold (\_ acc -> acc + 1) 0 relIn

281288

282−

283−

289+relationMax :: Relation -> Atom

290+relationMax relIn = IntAtom $ relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn

291+ where

292+ newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0

293+

294+relationMin :: Relation -> Atom

295+relationMin relIn = IntAtom $ relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn

296+ where

297+ newVal tupIn = (\(IntAtom i) -> i) $ (tupleAtoms tupIn) V.! 0

ProjectM36/RelationalExpression.hs+37−46

@@ -6,6 +6,7 @@ import ProjectM36.TupleSet

66import ProjectM36.Base

77import ProjectM36.Error

88import ProjectM36.Atom

9+import ProjectM36.AtomFunction

910import qualified ProjectM36.Attribute as A

1011import qualified Data.Map as M

1112import qualified Data.HashSet as HS

@@ -99,7 +100,7 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do

99100 case tupleExpressionProcessor rel tupleExpression context of

100101 Left err -> return $ Left err

101102 Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel

102−

103+

103104emptyDatabaseContext :: DatabaseContext

104105emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

105106 relationVariables = M.empty,

@@ -359,7 +360,6 @@ predicateRestrictionFilter context (AttributeEqualityPredicate attrName atomexpr

359360 case evalAtomExpr tupleIn context atomexpr of

360361 Left _ -> False

361362 Right atomCmp -> atomCmp == atomIn

362−

363363

364364tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

365365tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then

@@ -379,25 +379,19 @@ tupleExpressionProcessor relIn

379379 Left _ -> undefined -- ?!

380380 Right atom -> tupleAtomExtend newAttrName atom tup)

381381

382−basicAtomFunctions :: AtomFunctions

383−basicAtomFunctions = HS.fromList [

384− --match on any relation type

385− AtomFunction "add" [IntAtomType, IntAtomType, IntAtomType] (\(i1:i2:_) -> (\(IntAtom a) (IntAtom b) -> IntAtom (a + b)) i1 i2),

386− AtomFunction { atomFuncName = "id",

387− atomFuncType = [AnyAtomType],

388− atomFunc = (\(x:_) -> x)}

389−

390−-- AtomFunction "count" [RelationAtomType , IntAtom],

391−-- AtomFunction "sum" [RelationAtomType IntAtomType

392− ]

393−

394−atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

395−atomFunctionForName funcName funcSet = if HS.null foundFunc then

396− Left $ NoSuchTupleExprFunctionError funcName

397− else

398− Right $ head $ HS.toList foundFunc

399− where

400− foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet

382+evalAtomExpr :: RelationTuple -> DatabaseContext -> AtomExpr -> Either RelationalError Atom

383+evalAtomExpr tupIn _ (AttributeAtomExpr attrName) = atomForAttributeName attrName tupIn

384+evalAtomExpr _ _ (NakedAtomExpr atom) = Right atom

385+evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do

386+ let functions = atomFunctions context

387+ func <- atomFunctionForName funcName functions

388+ argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) context) arguments

389+ _ <- mapM (uncurry atomTypeVerify) $ init (zip (atomFuncType func) argTypes)

390+ evaldArgs <- mapM (evalAtomExpr tupIn context) arguments

391+ return $ (atomFunc func) evaldArgs

392+evalAtomExpr _ context (RelationAtomExpr relExpr) = do

393+ relAtom <- evalState (evalRelationalExpr relExpr) context

394+ return $ RelationAtom relAtom

401395

402396typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType

403397typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs

@@ -409,7 +403,6 @@ typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do

409403typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do

410404 relType <- evalState (typeForRelationalExpr relExpr) context

411405 return $ RelationAtomType (attributes relType)

412−

413406

414407verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType

415408verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do

@@ -433,27 +426,25 @@ verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do

433426 case runState (typeForRelationalExpr relationExpr) context of

434427 (Left err, _) -> Left err

435428 (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))

436−

437−--determine if two types are equal or compatible

438−atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType

439−atomTypeVerify AnyAtomType x = Right x

440−atomTypeVerify x AnyAtomType = Right x

441−atomTypeVerify x y = if x == y then

442− Right x

443− else

444− Left $ AtomTypeMismatchError x y

445−

446−evalAtomExpr :: RelationTuple -> DatabaseContext -> AtomExpr -> Either RelationalError Atom

447−evalAtomExpr tupIn _ (AttributeAtomExpr attrName) = atomForAttributeName attrName tupIn

448−evalAtomExpr _ _ (NakedAtomExpr atom) = Right atom

449−evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do

450− let functions = atomFunctions context

451− func <- atomFunctionForName funcName functions

452− argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) context) arguments

453− _ <- mapM (uncurry atomTypeVerify) $ init (zip (atomFuncType func) argTypes)

454− evaldArgs <- mapM (evalAtomExpr tupIn context) arguments

455− return $ (atomFunc func) evaldArgs

456−evalAtomExpr _ context (RelationAtomExpr relExpr) = do

457− relAtom <- evalState (evalRelationalExpr relExpr) context

458− return $ RelationAtom relAtom

459−

429+

430+basicAtomFunctions :: AtomFunctions

431+basicAtomFunctions = HS.fromList [

432+ --match on any relation type

433+ AtomFunction "add" [IntAtomType, IntAtomType, IntAtomType] (\(i1:i2:_) -> (\(IntAtom a) (IntAtom b) -> IntAtom (a + b)) i1 i2),

434+ AtomFunction { atomFuncName = "id",

435+ atomFuncType = [AnyAtomType, AnyAtomType],

436+ atomFunc = (\(x:_) -> x)},

437+ AtomFunction { atomFuncName = "sum",

438+ atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

439+ atomFunc = (\((RelationAtom relIn):_) -> relationSum relIn)},

440+ AtomFunction { atomFuncName = "count",

441+ atomFuncType = foldAtomFuncType AnyAtomType IntAtomType,

442+ atomFunc = (\((RelationAtom relIn):_) -> relationCount relIn)},

443+ AtomFunction { atomFuncName = "max",

444+ atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

445+ atomFunc = (\((RelationAtom relIn):_) -> relationMax relIn)},

446+ AtomFunction { atomFuncName = "min",

447+ atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

448+ atomFunc = (\((RelationAtom relIn):_) -> relationMin relIn)}

449+

450+ ]

ProjectM36/Tuple.hs+13−3

@@ -163,9 +163,19 @@ verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs

163163 if V.length attrs /= V.length tupleTypes then

164164 Left $ TupleAttributeCountMismatchError 0

165165 else if attrsTypes /= tupleTypes then

166− Left $ TupleAttributeTypeMismatchError (attributesDifference attrs (tupleAttributes tuple))

166+ --Left $ traceShow (show attrsTypes ++ "gonk" ++ show tupleTypes ++ "done") $ TupleAttributeTypeMismatchError (attributesDifference attrs (tupleAttributes tuple))

167+ Left $ TupleAttributeTypeMismatchError (attributesDifference attrs (tupleAttributes tuple))

167168 else

168169 Right $ tuple

169170

170−

171−

171+--two tuples can be equal but the vectors of attributes could be out-of-order

172+--reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering

173+reorderTuple :: Attributes -> RelationTuple -> RelationTuple

174+reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

175+ tupIn

176+ else do

177+ RelationTuple attrs (V.map mapper attrs)

178+ where

179+ mapper attr = case atomForAttributeName (attributeName attr) tupIn of

180+ Left _ -> undefined

181+ Right atom -> atom

TutorialD/Interpreter.hs+36−10

@@ -129,11 +129,11 @@ tutDTypeToAtomType tutDType = case tutDType of

129129 "int" -> Just IntAtomType

130130 _ -> Nothing

131131

132−atomTypeToTutDType :: AtomType -> Maybe String

132+atomTypeToTutDType :: AtomType -> Maybe T.Text

133133atomTypeToTutDType atomType = case atomType of

134134 StringAtomType -> Just "char"

135135 IntAtomType -> Just "int"

136− --RelationAtomType rel ->

136+ RelationAtomType attrs -> Just $ "relation" `T.append` showRelationAttributes attrs

137137 _ -> Nothing

138138

139139relVarP :: Parser RelationalExpr

@@ -198,8 +198,33 @@ extendP = do

198198 tupleExpr <- braces tupleExpressionP

199199 return $ Extend tupleExpr

200200

201+{-

202+rewrite summarize as extend as evaluate

203+

204+summarize SP per (SP{SNO}) add (sum(@QTY) as SUMQ) === ((SP rename {QTY as _}) group ({_} as x)) : {QTY:=sum(@x)}{S#,QTY}

205+so, in general,

206+summarize rX per (relExpr) add (func(@attr) as funcd) === ((rX rename {attr as _}) group ({_} as _)) : {QTY:=sum(@_)}{relExpr, _}

207+-}

208+{-

209+summarizeP :: Parser (RelationalExpr -> RelationalExpr)

210+summarizeP = do

211+ reservedOp "per"

212+ -- "summarize in Tutorial D requires the heading of the per relation to be a subset of that of the relation to be summarized"

213+ perExpr <- parens relExpr

214+ reservedOp "add"

215+ (funcAtomExpr, newAttrName) <- parens summaryP

216+ --rewrite summarize as extend

217+ --return $ Summarize funcAtomExpr newAttrName perExpr

218+

219+summaryP :: Parser (AtomExpr, AttributeName)

220+summaryP = do

221+ expr <- atomExprP

222+ reserved "as"

223+ attrName <- identifier

224+ return (expr, T.pack attrName)

225+-}

226+

201227relOperators = [

202− [Postfix extendP],

203228 [Postfix projectOp],

204229 [Postfix renameP],

205230 [Postfix whereClauseP],

@@ -207,7 +232,8 @@ relOperators = [

207232 [Postfix ungroupP],

208233 [Infix (reservedOp "join" >> return Join) AssocLeft],

209234 [Infix (reservedOp "union" >> return Union) AssocLeft],

210− [Infix (reservedOp "=" >> return Equals) AssocNone]

235+ [Infix (reservedOp "=" >> return Equals) AssocNone],

236+ [Postfix extendP]

211237 ]

212238

213239relExpr :: Parser RelationalExpr

@@ -384,13 +410,13 @@ contextOps = typeP

384410interpreterOps :: Parser (Either ContextOperator GraphOperator)

385411interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps

386412

387−showRelationAttributes :: Relation -> T.Text

388−showRelationAttributes rel = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrs) `T.append` "}"

413+showRelationAttributes :: Attributes -> T.Text

414+showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"

389415 where

390416 showAttribute (Attribute name atomType) = name `T.append` " " `T.append` case atomTypeToTutDType atomType of

391− Just t -> T.pack (show t)

392− Nothing -> T.pack "unknown"

393− attrs = V.toList $ attributes rel

417+ Just t -> t

418+ Nothing -> "unknown"

419+ attrsL = V.toList attrs

394420

395421data TutorialDOperatorResult = QuitResult |

396422 DisplayResult StringType |

@@ -400,7 +426,7 @@ data TutorialDOperatorResult = QuitResult |

400426

401427evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult

402428evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of

403− (Right rel, _) -> DisplayResult $ showRelationAttributes rel

429+ (Right rel, _) -> DisplayResult $ showRelationAttributes (attributes rel)

404430 (Left err, _) -> DisplayErrorResult $ T.pack (show err)

405431

406432evalContextOp context (ShowRelation expr) = do

project-m36.cabal+1

@@ -16,6 +16,7 @@ Library

1616 ProjectM36.Tuple,

1717 ProjectM36.TupleSet,

1818 ProjectM36.Atom,

19+ ProjectM36.AtomFunction,

1920 ProjectM36.RelationalExpression,

2021 ProjectM36.Relation.Show.HTML,

2122 ProjectM36.StaticOptimizer,

test/TutorialD/Interpreter.hs+14−3

@@ -18,6 +18,7 @@ import Data.UUID (nil)

1818import Data.Either (isRight)

1919import qualified Data.Vector as V

2020

21+--urgent: add group and ungroup tests- I missed the group relation type bug

2122main :: IO ()

2223main = do

2324 tcounts <- runTestTT (TestList tests)

@@ -57,14 +58,24 @@ main = do

5758 simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]

5859 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]

5960 extendTestAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]

61+ groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]

62+ minMaxAttrs = A.attributesFromList [Attribute "S#" StringAtomType, Attribute "z" IntAtomType]

6063 dateExampleRelTests = [("x:=S where true", Right suppliersRel),

6164 ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ StringAtom "London")) suppliersRel),

6265 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),

6366 ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [ Attribute "STATUS" IntAtomType]) (HS.singleton $ mkRelationTuple (A.attributesFromList [Attribute "STATUS" IntAtomType]) (V.fromList [IntAtom 50]))),

64− ("x:=(S : {STATUS2 := add(10,@STATUS)} where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),

67+ --atom function tests

68+ ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),

6569 ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel),

66− ("x:=relation{tuple{a int(5)}} : {b:=S}", mkRelation extendTestAttributes (HS.singleton $ mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel])))

67− ]

70+ ("x:=relation{tuple{a int(5)}} : {b:=S}", mkRelation extendTestAttributes (HS.singleton $ mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel]))),

71+ --relatom function tests

72+ ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (HS.singleton $ mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1))),

73+ ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),

74+ ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=max(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),

75+ ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=min(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),

76+ ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=sum(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)]))

77+ ]

78+

6879

6980assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion

7081assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted