db6f80d · project-m36 · git.iko.soy

git.iko.soy/project-m36

add boolean atoms, boolean functions, boolean function restriction

-also fix some warnings from top-level declarations

commitdb6f80dd5afd748ecac1d710d4b0c14f8f3f15dc authorAgentM <agentm@Ian-McAuleys-MacBook-Pro.local> dateThu 4 Jun 2015, 19:43 (11 years ago) parent177ecca

12 files changed+118−46

compare with master

unifiedsplit

ProjectM36/Atom.hs+1 ProjectM36/Base.hs+3 ProjectM36/Relation.hs+1−8 ProjectM36/Relation/Show/CSV.hs+2−1 ProjectM36/Relation/Show/HTML.hs+1 ProjectM36/Relation/Show/Term.hs+1 ProjectM36/RelationalExpression.hs+64−31 TutorialD/Interpreter/Base.hs+15−1 TutorialD/Interpreter/RelationalExpr.hs+19−2 benchmark/bigrel.hs+3−1 project-m36.cabal+1−1 test/TutorialD/Interpreter.hs+7−1

ProjectM36/Atom.hs+1

@@ -11,3 +11,4 @@ atomTypeForAtom :: Atom -> AtomType

1111atomTypeForAtom (StringAtom _) = StringAtomType

1212atomTypeForAtom (IntAtom _) = IntAtomType

1313atomTypeForAtom (RelationAtom (Relation attributes _)) = RelationAtomType attributes

14+atomTypeForAtom (BoolAtom _) = BoolAtomType

ProjectM36/Base.hs+3

@@ -17,6 +17,7 @@ type StringType = T.Text

1717

1818data Atom = StringAtom StringType |

1919 IntAtom Int |

20+ BoolAtom Bool |

2021 RelationAtom Relation

2122 deriving (Show, Eq, Generic)

2223

@@ -26,6 +27,7 @@ instance Hash.Hashable Atom

2627

2728data AtomType = StringAtomType |

2829 IntAtomType |

30+ BoolAtomType |

2931 RelationAtomType Attributes |

3032 AnyAtomType --AnyAtomType is used as a wildcard

3133 deriving (Eq, Show, Generic)

@@ -150,6 +152,7 @@ data RestrictionPredicateExpr where

150152 OrPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr -> RestrictionPredicateExpr

151153 NotPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr

152154 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

155+ AtomExprPredicate :: AtomExpr -> RestrictionPredicateExpr --atom must evaluate to boolean

153156 AttributeEqualityPredicate :: AttributeName -> AtomExpr -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

154157 deriving (Show, Eq)

155158

ProjectM36/Relation.hs+1−8

@@ -30,11 +30,6 @@ attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNam

3030atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType

3131atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs

3232

33−atomValueType :: Atom -> AtomType

34−atomValueType (StringAtom _) = StringAtomType

35−atomValueType (IntAtom _) = IntAtomType

36−atomValueType (RelationAtom rel) = RelationAtomType (attributes rel)

37−

3833mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation

3934mkRelationFromList attrs atomMatrix = do

4035 tupSet <- mkTupleSetFromList attrs atomMatrix

@@ -182,13 +177,11 @@ ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of

182177 newAttrs = A.addAttributes relvalAttrs nonGroupAttrs

183178 nonGroupAttrs = A.deleteAttributeName relvalAttrName (attributes rel)

184179 relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation

185− relFolder tupleIn acc = case (tupleUngroup relvalAttrName newAttrs tupleIn) of

186− Right ungroupRelation -> case acc of

180+ relFolder tupleIn acc = case acc of

187181 Left err -> Left err

188182 Right accRel -> do

189183 ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn

190184 union accRel ungrouped

191− Left err -> Left err

192185

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

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

ProjectM36/Relation/Show/CSV.hs+2−1

@@ -17,8 +17,9 @@ instance ToRecord RelationTuple where

1717 toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple)

1818

1919instance ToField Atom where

20+ toField (BoolAtom atom) = toField (if atom then "t" else "f")

2021 toField (StringAtom atom) = toField atom

2122 toField (IntAtom atom) = toField atom

22− toField (RelationAtom atom) = undefined -- CSV does not support nested relations- this should likely be detected and rejected

23+ toField (RelationAtom _) = undefined -- CSV does not support nested relations- this should likely be detected and rejected

2324

2425

ProjectM36/Relation/Show/HTML.hs+1

@@ -31,6 +31,7 @@ atomAsHTML :: Atom -> Text

3131atomAsHTML (StringAtom atom) = atom

3232atomAsHTML (IntAtom int) = pack (show int)

3333atomAsHTML (RelationAtom rel) = relationAsHTML rel

34+atomAsHTML (BoolAtom bool) = pack (show bool)

3435

3536tupleAsHTML :: RelationTuple -> Text

3637tupleAsHTML tuple = "<tr>" `append` T.concat (L.map tupleFrag (tupleSortedAssocs tuple)) `append` "</tr>"

ProjectM36/Relation/Show/Term.hs+1

@@ -95,6 +95,7 @@ showAtom :: Atom -> StringType

9595showAtom (StringAtom atom) = atom

9696showAtom (IntAtom atom) = T.pack $ show atom

9797showAtom (RelationAtom rel) = renderTable $ relationAsTable rel

98+showAtom (BoolAtom bool) = T.pack $ show bool

9899

99100renderTable :: Table -> StringType

100101renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd table) cellLocs

ProjectM36/RelationalExpression.hs+64−31

@@ -13,7 +13,6 @@ import qualified Data.HashSet as HS

1313import Control.Monad.State hiding (join)

1414import Data.Maybe

1515import Data.Either

16−import Debug.Trace

1716

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

1918evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)

@@ -77,7 +76,7 @@ evalRelationalExpr (Restrict predicateExpr relExpr) = do

7776 context <- get

7877 case evald of

7978 Left err -> return $ Left err

80− Right rel -> case predicateRestrictionFilter context predicateExpr of

79+ Right rel -> case predicateRestrictionFilter context (attributes rel) predicateExpr of

8180 Left err -> return $ Left err

8281 Right filterfunc -> return $ restrict filterfunc rel

8382

@@ -167,7 +166,7 @@ supplierProductsRel = case mkRelationFromList attrs matrix of

167166

168167productsRel :: Relation

169168productsRel = case mkRelationFromList attrs matrix of

170− Left err -> traceShow (show err) undefined

169+ Left _ -> undefined

171170 Right rel -> rel

172171 where

173172 attrs = A.attributesFromList [Attribute "P#" StringAtomType,

@@ -242,20 +241,20 @@ evalContextExpr (Delete relVarName predicate) = do

242241evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do

243242 currstate <- get

244243 let relVarTable = relationVariables currstate

245− case predicateRestrictionFilter currstate restrictionPredicateExpr of

246− Left err -> return $ Just err

247− Right predicateFunc -> do

248− case M.lookup relVarName relVarTable of

249− Nothing -> return $ Just (RelVarNotDefinedError relVarName)

250− Just rel -> case makeUpdatedRel rel of

251− Left err -> return $ Just err

252− Right updatedRel -> setRelVar relVarName updatedRel

253− where

254− makeUpdatedRel relin = do

255− restrictedPortion <- restrict predicateFunc relin

256− unrestrictedPortion <- restrict (not . predicateFunc) relin

257− updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion

258− union updatedPortion unrestrictedPortion

244+ case M.lookup relVarName relVarTable of

245+ Nothing -> return $ Just (RelVarNotDefinedError relVarName)

246+ Just rel -> case predicateRestrictionFilter currstate (attributes rel) restrictionPredicateExpr of

247+ Left err -> return $ Just err

248+ Right predicateFunc -> do

249+ case makeUpdatedRel rel of

250+ Left err -> return $ Just err

251+ Right updatedRel -> setRelVar relVarName updatedRel

252+ where

253+ makeUpdatedRel relin = do

254+ restrictedPortion <- restrict predicateFunc relin

255+ unrestrictedPortion <- restrict (not . predicateFunc) relin

256+ updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion

257+ union updatedPortion unrestrictedPortion

259258

260259evalContextExpr (AddInclusionDependency dep) = do

261260 currstate <- get

@@ -328,24 +327,24 @@ contextWithEmptyTupleSets contextIn = DatabaseContext incDeps relVars funcs

328327 funcs = atomFunctions contextIn

329328

330329{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

331−predicateRestrictionFilter :: DatabaseContext -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)

332−predicateRestrictionFilter context (AndPredicate expr1 expr2) = do

333− expr1v <- predicateRestrictionFilter context expr1

334− expr2v <- predicateRestrictionFilter context expr2

330+predicateRestrictionFilter :: DatabaseContext -> Attributes -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)

331+predicateRestrictionFilter context attrs (AndPredicate expr1 expr2) = do

332+ expr1v <- predicateRestrictionFilter context attrs expr1

333+ expr2v <- predicateRestrictionFilter context attrs expr2

335334 return $ \x -> expr1v x && expr2v x

336335

337−predicateRestrictionFilter context (OrPredicate expr1 expr2) = do

338− expr1v <- predicateRestrictionFilter context expr1

339− expr2v <- predicateRestrictionFilter context expr2

336+predicateRestrictionFilter context attrs (OrPredicate expr1 expr2) = do

337+ expr1v <- predicateRestrictionFilter context attrs expr1

338+ expr2v <- predicateRestrictionFilter context attrs expr2

340339 return $ \x -> expr1v x || expr2v x

341340

342−predicateRestrictionFilter _ TruePredicate = Right $ \_ -> True

341+predicateRestrictionFilter _ _ TruePredicate = Right $ \_ -> True

343342

344−predicateRestrictionFilter context (NotPredicate expr) = do

345− exprv <- predicateRestrictionFilter context expr

343+predicateRestrictionFilter context attrs (NotPredicate expr) = do

344+ exprv <- predicateRestrictionFilter context attrs expr

346345 return $ \x -> not (exprv x)

347346

348−predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of

347+predicateRestrictionFilter context _ (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of

349348 (Left err, _) -> Left err

350349 (Right rel, _) -> if rel == relationTrue then

351350 Right $ \_ -> True

@@ -354,12 +353,22 @@ predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runS

354353 else

355354 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"

356355

357−predicateRestrictionFilter context (AttributeEqualityPredicate attrName atomexpr) = Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of

356+predicateRestrictionFilter context _ (AttributeEqualityPredicate attrName atomexpr) = Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of

358357 Left _ -> False

359358 Right atomIn ->

360359 case evalAtomExpr tupleIn context atomexpr of

361360 Left _ -> False

362361 Right atomCmp -> atomCmp == atomIn

362+

363+-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

364+predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do

365+ aType <- typeFromAtomExpr attrs context atomExpr

366+ if aType /= BoolAtomType then

367+ Left $ AtomTypeMismatchError aType BoolAtomType

368+ else

369+ Right (\tupleIn -> case evalAtomExpr tupleIn context atomExpr of

370+ Left _ -> False

371+ Right boolAtomValue -> boolAtomValue == BoolAtom True)

363372

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

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

@@ -445,6 +454,30 @@ basicAtomFunctions = HS.fromList [

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

446455 AtomFunction { atomFuncName = "min",

447456 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,

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

449−

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

458+ AtomFunction { atomFuncName = "lt",

459+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

460+ atomFunc = intAtomFuncLessThan False},

461+ AtomFunction { atomFuncName = "lte",

462+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

463+ atomFunc = intAtomFuncLessThan True},

464+ AtomFunction { atomFuncName = "gte",

465+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

466+ atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},

467+ AtomFunction { atomFuncName = "gt",

468+ atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],

469+ atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},

470+ AtomFunction { atomFuncName = "not",

471+ atomFuncType = [BoolAtomType, BoolAtomType],

472+ atomFunc = boolAtomNot}

450473 ]

474+

475+intAtomFuncLessThan :: Bool -> [Atom] -> Atom

476+intAtomFuncLessThan equality (iatom1:iatom2:_) = (\(IntAtom i1) (IntAtom i2) -> BoolAtom $ i1 `op` i2) iatom1 iatom2

477+ where

478+ op = if equality then (<=) else (<)

479+intAtomFuncLessThan _ _= BoolAtom False

480+

481+boolAtomNot :: [Atom] -> Atom

482+boolAtomNot (BoolAtom bool:_) = BoolAtom $ not bool

483+boolAtomNot _ = BoolAtom False

TutorialD/Interpreter/Base.hs+15−1

@@ -1,6 +1,7 @@

11{-# LANGUAGE OverloadedStrings #-}

22module TutorialD.Interpreter.Base where

33import Text.Parsec

4+import Text.Parsec.String

45import qualified Text.Parsec.Token as Token

56import Text.Parsec.Language

67import ProjectM36.Base

@@ -16,13 +17,26 @@ lexer = Token.makeTokenParser tutD

1617 Token.identStart = letter <|> char '_',

1718 Token.opLetter = oneOf ":!#$%&*+./<=>?\\^|-~", -- remove "@" so it can be used as attribute marker without spaces

1819 Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples

19−

20+

21+parens :: Parser a -> Parser a

2022parens = Token.parens lexer

23+

24+reservedOp :: String -> Parser ()

2125reservedOp = Token.reservedOp lexer

26+

27+reserved :: String -> Parser ()

2228reserved = Token.reserved lexer

29+

30+braces :: Parser a -> Parser a

2331braces = Token.braces lexer

32+

33+identifier :: Parser String

2434identifier = Token.identifier lexer

35+

36+comma :: Parser String

2537comma = Token.comma lexer

38+

39+semi :: Parser String

2640semi = Token.semi lexer

2741

2842--convert Tutorial D type to AtomType

TutorialD/Interpreter/RelationalExpr.hs+19−2

@@ -13,6 +13,7 @@ import ProjectM36.Atom

1313import qualified Data.Vector as V

1414import qualified Data.Set as S

1515import Control.Applicative (liftA, (<*), (*>), (<$>))

16+import Data.Functor.Identity (Identity)

1617

1718--used in projection

1819attributeListP :: Parser [AttributeName]

@@ -142,6 +143,7 @@ summaryP = do

142143 return (expr, T.pack attrName)

143144-}

144145

146+relOperators :: [[Operator String () Identity RelationalExpr]]

145147relOperators = [

146148 [Postfix projectP],

147149 [Postfix renameP],

@@ -174,14 +176,16 @@ restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm

174176 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]

175177 ]

176178 predicateTerm = parens restrictionPredicateP

179+ <|> try restrictionAtomExprP

177180 <|> try restrictionAttributeEqualityP

178181 <|> try relationalBooleanExprP

179182

183+

180184relationalBooleanExprP :: Parser RestrictionPredicateExpr

181185relationalBooleanExprP = do

182186 relexpr <- relExprP

183187 return $ RelationalExprPredicate relexpr

184−

188+

185189restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr

186190restrictionAttributeEqualityP = do

187191 attributeName <- identifier

@@ -189,6 +193,10 @@ restrictionAttributeEqualityP = do

189193 atomexpr <- atomExprP

190194 return $ AttributeEqualityPredicate (T.pack attributeName) atomexpr

191195

196+restrictionAtomExprP :: Parser RestrictionPredicateExpr --atoms which are of type "boolean"

197+restrictionAtomExprP = do

198+ _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar

199+ AtomExprPredicate <$> atomExprP

192200

193201multiTupleExpressionP :: Parser [TupleExpr]

194202multiTupleExpressionP = sepBy tupleExpressionP comma

@@ -216,7 +224,7 @@ attributeAtomExprP = do

216224 return $ AttributeAtomExpr (T.pack attrName)

217225

218226nakedAtomExprP :: Parser AtomExpr

219−nakedAtomExprP = NakedAtomExpr <$> (stringAtomP <|> intAtomP)

227+nakedAtomExprP = NakedAtomExpr <$> (stringAtomP <|> intAtomP <|> boolAtomP)

220228

221229functionAtomExprP :: Parser AtomExpr

222230functionAtomExprP = do

@@ -227,11 +235,20 @@ functionAtomExprP = do

227235relationalAtomExprP :: Parser AtomExpr

228236relationalAtomExprP = RelationAtomExpr <$> relExprP

229237

238+quotedChar :: Parser Char

230239quotedChar = noneOf "\""

231240 <|> try (string "\"\"" >> return '"')

232241

242+stringAtomP :: Parser Atom

233243stringAtomP = liftA (StringAtom . T.pack) (string "\"" *> many quotedChar <* string "\"")

234244

245+intAtomP :: Parser Atom

235246intAtomP = do

236247 intstr <- many1 digit

237248 return $ IntAtom (read intstr)

249+

250+boolAtomP :: Parser Atom

251+boolAtomP = do

252+ val <- char 't' <|> char 'f'

253+ return $ BoolAtom (val == 't')

254+

benchmark/bigrel.hsmode 100644 → 100755+3−1

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

1515import qualified Data.Map as M

1616import qualified Data.Text.IO as TIO

1717import System.IO

18+import Control.Monad.State

1819

1920dumpcsv :: Relation -> IO ()

2021dumpcsv = BS.putStrLn . relationAsCSV

@@ -57,7 +58,8 @@ matrixRun (BigrelArgs attributeCount tupleCount tutd) = do

5758 putStrLn "Done."

5859 else do

5960 let setx = Assign "x" (ExistingRelation rel)

60− interpreted = interpretDatabaseExpr dateExamples tutd

61+ context = execState (evalContextExpr setx) dateExamples

62+ interpreted = interpretDatabaseExpr context tutd

6163 case interpreted of

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

6365 Left err -> hPutStrLn stderr (show err)

project-m36.cabalmode 100644 → 100755+1−1

@@ -7,7 +7,7 @@ Category: Relational Algebra

77Cabal-Version: >= 1.2

99Library

10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel

10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers

1111 Exposed-Modules: ProjectM36.Error,

1212 ProjectM36.Transaction,

1313 ProjectM36.Transaction.Show,

test/TutorialD/Interpreter.hs+7−1

@@ -74,7 +74,13 @@ main = do

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

7575 ("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)])),

7676 ("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)])),

77− ("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+ ("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)])),

78+ --boolean function restriction

79+ ("x:=S where ^lt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]]),

80+ ("x:=S where ^gt(@STATUS,20)", mkRelationFromList (attributes suppliersRel) [[StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],

81+ [StringAtom "S5", StringAtom "Adams", IntAtom 30, StringAtom "Athens"]]),

82+ ("x:=S where ^sum(@STATUS)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),

83+ ("x:=S where ^not(gte(@STATUS,20))", mkRelationFromList (attributes suppliersRel) [[StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"]])

7884 ]

7985

8086