9835bf4 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP: lots of refactoring for new constructed atom types and primitive types separation

9835bf4AgentM11 years ago

Database/Persist/ProjectM36.hs+3−1

compare with master

unifiedsplit

@@ -76,6 +76,8 @@ persistValueAtom val = case val of

76 _ -> Nothing

78atomAsPersistValue :: Atom -> PersistValue

79+--constructed atoms are written as text to the database

80+atomAsPersistValue atom@(ConstructedAtom _ _ _) = PersistText (atomToText atom)

79atomAsPersistValue atom@(Atom atomv) = if typeRep (Proxy :: Proxy Int) == typeOf atomv then

81atomAsPersistValue atom@(Atom atomv) = if typeRep (Proxy :: Proxy Int) == typeOf atomv then

80 PersistInt64 (fromIntegral ((unsafeCast atom) :: Int))

82 PersistInt64 (fromIntegral ((unsafeCast atom) :: Int))

81 else if typeRep (Proxy :: Proxy T.Text) == typeOf atomv then

83 else if typeRep (Proxy :: Proxy T.Text) == typeOf atomv then

@@ -523,7 +525,7 @@ instance PersistQuery ProjectM36Backend where

523 allAttrNamesList = map (unDBName . fieldDB) (entityFields entDef) ++ [unDBName (fieldDB (entityId entDef))]

525 allAttrNamesList = map (unDBName . fieldDB) (entityFields entDef) ++ [unDBName (fieldDB (entityId entDef))]

524 allAttrNames = AttributeNames $ S.fromList allAttrNamesList

526 allAttrNames = AttributeNames $ S.fromList allAttrNamesList

525 groupExpr = Group allAttrNames "persistcountrel" (Restrict restrictionPredicate (RelationVariable relVarName))

527 groupExpr = Group allAttrNames "persistcountrel" (Restrict restrictionPredicate (RelationVariable relVarName))

526− tupleExpr = AttributeTupleExpr "persistcount" (FunctionAtomExpr "count" [AttributeAtomExpr "persistcountrel"])

528+ tupleExpr = AttributeExtendTupleExpr "persistcount" (FunctionAtomExpr "count" [AttributeAtomExpr "persistcountrel"])

527 countExpr = Extend tupleExpr groupExpr

529 countExpr = Extend tupleExpr groupExpr

528 rel <- Trans.liftIO $ C.executeRelationalExpr sessionId conn countExpr

530 rel <- Trans.liftIO $ C.executeRelationalExpr sessionId conn countExpr

529 case rel of

531 case rel of

ProjectM36/Atom.hs+12−39

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

8import Data.Time.Calendar (Day)

9import Data.Time.Clock

10import Data.ByteString (ByteString)

11−import qualified Data.Map as M

13relationForAtom :: Atom -> Either RelationalError Relation

12relationForAtom :: Atom -> Either RelationalError Relation

14relationForAtom (Atom atom) = case cast atom of

13relationForAtom (Atom atom) = case cast atom of

@@ -16,30 +15,6 @@ relationForAtom (Atom atom) = case cast atom of

16 Nothing -> Left $ AttributeIsNotRelationValuedError ""

15 Nothing -> Left $ AttributeIsNotRelationValuedError ""

17relationForAtom (ConstructedAtom _ _ _) = Left $ AttributeIsNotRelationValuedError ""

16relationForAtom (ConstructedAtom _ _ _) = Left $ AttributeIsNotRelationValuedError ""

19−atomTypeForProxy :: (Atomable a) => Proxy a -> AtomType

20−atomTypeForProxy prox = AtomType $ CTR (typeRep prox)

21−

22−--some convenience functions

23−stringAtomType :: AtomType

24−stringAtomType = atomTypeForProxy (Proxy :: Proxy StringType)

25−

26−intAtomType :: AtomType

27−intAtomType = atomTypeForProxy (Proxy :: Proxy Int)

28−

29−boolAtomType :: AtomType

30−boolAtomType = atomTypeForProxy (Proxy :: Proxy Bool)

31−

32−dateAtomType :: AtomType

33−dateAtomType = atomTypeForProxy (Proxy :: Proxy Day)

34−

35−dateTimeAtomType :: AtomType

36−dateTimeAtomType = atomTypeForProxy (Proxy :: Proxy UTCTime)

37−

38−byteStringAtomType :: AtomType

39−byteStringAtomType = atomTypeForProxy (Proxy :: Proxy ByteString)

40−

41−doubleAtomType :: AtomType

42−doubleAtomType = atomTypeForProxy (Proxy :: Proxy Double)

44--another hard-coded typerep dispatch table :/

19--another hard-coded typerep dispatch table :/

45makeAtomFromText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom

20makeAtomFromText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom

@@ -62,9 +37,8 @@ makeAtomFromText _ (AtomType cTypeRep) textIn = if

62 Left $ ParseError textIn

37 Left $ ParseError textIn

63makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName

38makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName

65−--textAtom shortcut

66−stringAtom :: T.Text -> Atom

40+textAtom :: T.Text -> Atom

67−stringAtom t = Atom t

41+textAtom t = Atom t

69--intAtom shortcut

43--intAtom shortcut

70intAtom :: Int -> Atom

44intAtom :: Int -> Atom

@@ -77,15 +51,14 @@ castRelation (Atom atom) = case cast atom of

77 Just rel -> rel

51 Just rel -> rel

78 Nothing -> error "castRelation attempt on non-relation-typed Atom"

52 Nothing -> error "castRelation attempt on non-relation-typed Atom"

80−unsafeCast :: (Atomable a) => Atom -> a

54+{-

81−unsafeCast (ConstructedAtom _ _ _) = error "unsafeCast attempt on ConstructedAtom"

82−unsafeCast (Atom atom) = case cast atom of

83− Just x -> x

84− Nothing -> error "unsafeCast failed"

85−

86−emptyAtomConstructor :: AtomConstructor

87−emptyAtomConstructor = AtomConstructor M.empty

88−

89basicAtomTypes :: AtomTypes

55basicAtomTypes :: AtomTypes

90−basicAtomTypes = M.fromList [("Int", (intAtomType, emptyAtomConstructor))]

56+basicAtomTypes = M.union primitiveAtomTypes moreTypes

91−

57+ where

58+ moreTypes = M.fromList [("Day", (dateAtomType,

59+ AtomConstructor (M.singleton "Day" ["Int"])))

60+ ]

61+-}

62+atomToText :: Atom -> T.Text

63+atomToText (Atom atom) = toText atom

64+atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)

ProjectM36/AtomConstructor.hsnew file+7

@@ -0,0 +1,7 @@

1+module ProjectM36.AtomConstructor where

2+import ProjectM36.Base

3+import qualified Data.Map as M

5+emptyAtomConstructor :: AtomConstructor

6+emptyAtomConstructor = AtomConstructor M.empty

ProjectM36/AtomFunctions/Basic.hsnew file+11

@@ -0,0 +1,11 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+--atom functions on primitive atom values plus the basic atom functions

3+module ProjectM36.AtomFunctions.Basic where

4+import ProjectM36.Base

5+import ProjectM36.DataTypes.Day

6+import ProjectM36.AtomFunctions.Primitive

7+import qualified Data.HashSet as HS

9+basicAtomFunctions :: AtomFunctions

10+basicAtomFunctions = primitiveAtomFunctions `HS.union` dayFunctions

11+

ProjectM36/AtomFunctions/Primitive.hsnew file+100

@@ -0,0 +1,100 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.AtomFunctions.Primitive where

3+import ProjectM36.Atom

4+import ProjectM36.Base

5+import ProjectM36.Relation (relFold)

6+import ProjectM36.Tuple

7+import ProjectM36.AtomFunction

8+import ProjectM36.DataTypes.Primitive

9+import qualified Data.HashSet as HS

10+import Data.Typeable (cast)

11+import qualified Data.Vector as V

12+import qualified Data.ByteString.Base64 as B64

13+import qualified Data.Text.Encoding as TE

14+import qualified Data.Text as T

15+

16+primitiveAtomFunctions :: AtomFunctions

17+primitiveAtomFunctions = HS.fromList [

18+ --match on any relation type

19+ AtomFunction { atomFuncName = "add",

20+ atomFuncType = [intAtomType, intAtomType, intAtomType],

21+ atomFunc = (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},

22+ AtomFunction { atomFuncName = "id",

23+ atomFuncType = [AnyAtomType, AnyAtomType],

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

25+ AtomFunction { atomFuncName = "sum",

26+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

27+ atomFunc = (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},

28+ AtomFunction { atomFuncName = "count",

29+ atomFuncType = foldAtomFuncType AnyAtomType intAtomType,

30+ atomFunc = (\((relIn):_) -> relationCount (castRelation relIn))},

31+ AtomFunction { atomFuncName = "max",

32+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

33+ atomFunc = (\((relIn):_) -> relationMax (castRelation relIn))},

34+ AtomFunction { atomFuncName = "min",

35+ atomFuncType = foldAtomFuncType intAtomType intAtomType,

36+ atomFunc = (\((relIn):_) -> relationMin (castRelation relIn))},

37+ AtomFunction { atomFuncName = "lt",

38+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

39+ atomFunc = intAtomFuncLessThan False},

40+ AtomFunction { atomFuncName = "lte",

41+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

42+ atomFunc = intAtomFuncLessThan True},

43+ AtomFunction { atomFuncName = "gte",

44+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

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

46+ AtomFunction { atomFuncName = "gt",

47+ atomFuncType = [intAtomType, intAtomType, boolAtomType],

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

49+ AtomFunction { atomFuncName = "not",

50+ atomFuncType = [boolAtomType, boolAtomType],

51+ atomFunc = boolAtomNot},

52+ AtomFunction { atomFuncName = "makeByteString",

53+ atomFuncType = [textAtomType, byteStringAtomType],

54+ --I need a proper error-handling scheme for AtomFunctions!

55+ atomFunc = \(textIn:_) -> Atom $ (B64.decodeLenient . TE.encodeUtf8) ((unsafeCast textIn)::T.Text) }

56+ ]

57+

58+unsafeCast :: (Atomable a) => Atom -> a

59+unsafeCast (ConstructedAtom _ _ _) = error "unsafeCast attempt on ConstructedAtom"

60+unsafeCast (Atom atom) = case cast atom of

61+ Just x -> x

62+ Nothing -> error "unsafeCast failed"

63+

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

65+intAtomFuncLessThan equality (iatom1:iatom2:_) = (\i1 i2 -> Atom $ ((unsafeCast i1)::Int) `op` unsafeCast i2) iatom1 iatom2

66+ where

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

68+intAtomFuncLessThan _ _= Atom False

69+

70+boolAtomNot :: [Atom] -> Atom

71+boolAtomNot (bool:_) = Atom $ not (unsafeCast bool)

72+boolAtomNot _ = Atom False

73+

74+--used by sum atom function

75+relationSum :: Relation -> Atom

76+relationSum relIn = Atom $ relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn

77+ where

78+ --extract Int from Atom

79+ newVal :: RelationTuple -> Int

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

81+

82+relationCount :: Relation -> Atom

83+relationCount relIn = Atom $ relFold (\_ acc -> acc + 1) (0::Int) relIn

84+

85+relationMax :: Relation -> Atom

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

87+ where

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

89+

90+relationMin :: Relation -> Atom

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

92+ where

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

94+

95+castInt :: Atom -> Int

96+castInt (ConstructedAtom _ _ _) = error "castInt attempt on ConstructedAtom"

97+castInt (Atom atom) = case cast atom of

98+ Just i -> i

99+ Nothing -> error "int cast failure" -- the type checker must ensure this can never occur

100+

ProjectM36/AtomType.hs+5−4

@@ -2,6 +2,7 @@

2module ProjectM36.AtomType where

3import ProjectM36.Base

4import ProjectM36.Relation

5+import ProjectM36.DataTypes.Primitive

5import qualified Data.Text as T

6import qualified Data.Text as T

6import ProjectM36.Error

7import ProjectM36.Error

7import ProjectM36.Attribute

8import ProjectM36.Attribute

@@ -13,13 +14,13 @@ import Data.Either (isRight)

13typesAsRelation :: AtomTypes -> Either RelationalError Relation

14typesAsRelation :: AtomTypes -> Either RelationalError Relation

14typesAsRelation aTypes = mkRelationFromTuples attrs tuples

15typesAsRelation aTypes = mkRelationFromTuples attrs tuples

15 where

16 where

16− attrs = attributesFromList [Attribute "TypeConstructor" stringAtomType,

17+ attrs = attributesFromList [Attribute "TypeConstructor" textAtomType,

17 Attribute "DataConstructors" dConsType]

18 Attribute "DataConstructors" dConsType]

18− subAttrs = attributesFromList [Attribute "DataConstructor" stringAtomType]

19+ subAttrs = attributesFromList [Attribute "DataConstructor" textAtomType]

19 dConsType = RelationAtomType subAttrs

20 dConsType = RelationAtomType subAttrs

20 tuples = map mkTypeConsDescription (M.toList aTypes)

21 tuples = map mkTypeConsDescription (M.toList aTypes)

21− mkTypeConsDescription (tConsName, (_, AtomConstructor dConsMap)) = RelationTuple attrs (V.fromList [stringAtom tConsName, mkDataConsRelation dConsMap])

22+ mkTypeConsDescription (tConsName, (_, AtomConstructor dConsMap)) = RelationTuple attrs (V.fromList [textAtom tConsName, mkDataConsRelation dConsMap])

22− mkDataConsRelation dConsMap = case mkRelationFromTuples subAttrs $ map (\(dConsName, dConsTypeNames) -> RelationTuple subAttrs (V.singleton $ stringAtom $ T.intercalate " " (dConsName:dConsTypeNames))) (M.toList dConsMap) of

23+ mkDataConsRelation dConsMap = case mkRelationFromTuples subAttrs $ map (\(dConsName, dConsTypeNames) -> RelationTuple subAttrs (V.singleton $ textAtom $ T.intercalate " " (dConsName:dConsTypeNames))) (M.toList dConsMap) of

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

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

24 Right rel -> Atom rel

25 Right rel -> Atom rel

25{-

26{-

ProjectM36/Base.hs+18−17

@@ -23,6 +23,8 @@ import Data.Typeable

23import Text.Read (readMaybe)

24import Data.ByteString (ByteString)

25import ProjectM36.ConcreteTypeRep

26+import qualified Data.Text.Encoding as TE

27+import qualified Data.ByteString.Base64 as BS64

27type StringType = Text

29type StringType = Text

@@ -50,7 +52,8 @@ instance Atomable Text where

50 toText t = t

52 toText t = t

51instance Atomable Day

53instance Atomable Day

52instance Atomable UTCTime

54instance Atomable UTCTime

53−instance Atomable ByteString

55+instance Atomable ByteString where

56+ toText bs = TE.decodeUtf8With (\_ _ -> Just '?') (BS64.encode bs)

54instance Atomable Bool

57instance Atomable Bool

55instance Atomable Relation

58instance Atomable Relation

56instance (Atomable a) => Atomable (Maybe a)

59instance (Atomable a) => Atomable (Maybe a)

@@ -89,8 +92,6 @@ instance Binary Atom where

89 Atom <$> (get :: Get Double)

92 Atom <$> (get :: Get Double)

90 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then

93 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Day) then

91 Atom <$> (get :: Get Day)

94 Atom <$> (get :: Get Day)

92− else if unCTR cTypeRep == typeRep (Proxy :: Proxy UTCTime) then

93− Atom <$> (get :: Get UTCTime)

94 else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then

95 else if unCTR cTypeRep == typeRep (Proxy :: Proxy ByteString) then

95 Atom <$> (get :: Get ByteString)

96 Atom <$> (get :: Get ByteString)

96 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then

97 else if unCTR cTypeRep == typeRep (Proxy :: Proxy Bool) then

@@ -230,8 +231,10 @@ type RelVarName = StringType

230

231

231-- | A relational expression represents query (read) operations on a database.

232-- | A relational expression represents query (read) operations on a database.

232data RelationalExpr where

233data RelationalExpr where

233− --- | Create a relation from attribute and atom expressions.

234+ --- | Create a relation from tuple expressions.

235+ MakeRelationFromTupleExprs :: [TupleExpr] -> RelationalExpr

236+ --- | Create an empty relation with the given attributes.

234− MakeRelationFromAtomExprs :: [AttributeExpr] -> [AtomExpr] -> RelationalExpr

237+ MakeEmptyRelation :: [AttributeExpr] -> RelationalExpr

235 --- | Create and reference a relation from attributes and a tuple set.

238 --- | Create and reference a relation from attributes and a tuple set.

236 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

239 MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr

237 --- | Reference an existing relation in Haskell-space.

240 --- | Reference an existing relation in Haskell-space.

@@ -260,9 +263,7 @@ data RelationalExpr where

260 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

263 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

261 Extend :: ExtendTupleExpr -> RelationalExpr -> RelationalExpr

264 Extend :: ExtendTupleExpr -> RelationalExpr -> RelationalExpr

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

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

263− deriving (Show,Eq, Generic)

266+ deriving (Show, Eq, Generic, Binary)

264−

265−instance Binary RelationalExpr

266

267

267type NotificationName = StringType

268type NotificationName = StringType

268type Notifications = M.Map NotificationName Notification

269type Notifications = M.Map NotificationName Notification

@@ -294,7 +295,7 @@ instance Binary InclusionDependency

294

295

295-- | Database context expressions modify the database context.

296-- | Database context expressions modify the database context.

296data DatabaseExpr where

297data DatabaseExpr where

297− Define :: RelVarName -> Attributes -> DatabaseExpr

298+ Define :: RelVarName -> [AttributeExpr] -> DatabaseExpr

298 Undefine :: RelVarName -> DatabaseExpr --forget existence of relvar X

299 Undefine :: RelVarName -> DatabaseExpr --forget existence of relvar X

299 Assign :: RelVarName -> RelationalExpr -> DatabaseExpr

300 Assign :: RelVarName -> RelationalExpr -> DatabaseExpr

300 Insert :: RelVarName -> RelationalExpr -> DatabaseExpr

301 Insert :: RelVarName -> RelationalExpr -> DatabaseExpr

@@ -386,7 +387,7 @@ instance Eq Transaction where

386instance Ord Transaction where

387instance Ord Transaction where

387 compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB

388 compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB

388

389

389−-- | An atom expression represents an action to take when extending a relation.

390+-- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple.

390data AtomExpr = AttributeAtomExpr AttributeName |

391data AtomExpr = AttributeAtomExpr AttributeName |

391 NakedAtomExpr Atom |

392 NakedAtomExpr Atom |

392 FunctionAtomExpr AtomFunctionName [AtomExpr] |

393 FunctionAtomExpr AtomFunctionName [AtomExpr] |

@@ -396,12 +397,9 @@ data AtomExpr = AttributeAtomExpr AttributeName |

396

397

397instance Binary AtomExpr

398instance Binary AtomExpr

398

399

399−-- | A tuple expression declares what action to take when extending a relation.

400−data ExtendTupleExpr = AttributeExtendTupleExpr AttributeName AtomExpr

401− deriving (Show, Eq, Generic, Binary)

402−

403-- | Used in tuple creation when creating a relation.

400-- | Used in tuple creation when creating a relation.

404−data TupleExpr = TupleExpr Attributes [AtomExpr]

401+data ExtendTupleExpr = AttributeExtendTupleExpr AttributeName AtomExpr

402+ deriving (Show, Eq, Binary, Generic)

405

403

406--enumerates the list of functions available to be run as part of tuple expressions

404--enumerates the list of functions available to be run as part of tuple expressions

407type AtomFunctions = HS.HashSet AtomFunction

405type AtomFunctions = HS.HashSet AtomFunction

@@ -439,5 +437,8 @@ data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory

439 CrashSafePersistence FilePath -- ^ full fsync to disk (flushes kernel and physical drive buffers to ensure that the transaction is on non-volatile storage)

437 CrashSafePersistence FilePath -- ^ full fsync to disk (flushes kernel and physical drive buffers to ensure that the transaction is on non-volatile storage)

440 deriving (Show, Read)

438 deriving (Show, Read)

441

439

440+data AttributeExpr = AttributeAndTypeNameExpr AttributeName TypeConstructorName

441+ deriving (Eq, Show, Generic, Binary)

442+

442−data AttributeExpr = AttributeAndAtomExpr AttributeName AtomExpr |

443+data TupleExpr = TupleExpr (M.Map AttributeName AtomExpr)

443− AttributeAndTypeName AttributeName TypeConstructorName

444+ deriving (Eq, Show, Generic, Binary)

ProjectM36/Client.hs+2−1

@@ -52,6 +52,7 @@ import ProjectM36.Error

52import ProjectM36.StaticOptimizer

53import Control.Monad.State

54import qualified ProjectM36.RelationalExpression as RE

55+import ProjectM36.DatabaseContext (basicDatabaseContext)

55import ProjectM36.TransactionGraph

56import ProjectM36.TransactionGraph

56import ProjectM36.TransactionGraph.Persist

57import ProjectM36.TransactionGraph.Persist

57import ProjectM36.Attribute hiding (atomTypes)

58import ProjectM36.Attribute hiding (atomTypes)

@@ -179,7 +180,7 @@ connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

179--create a new in-memory database/transaction graph

180--create a new in-memory database/transaction graph

180connectProjectM36 (InProcessConnectionInfo strat notificationCallback) = do

181connectProjectM36 (InProcessConnectionInfo strat notificationCallback) = do

181 freshUUID <- nextRandom

182 freshUUID <- nextRandom

182− let bootstrapContext = RE.basicDatabaseContext

183+ let bootstrapContext = basicDatabaseContext

183 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext

184 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext

184 case strat of

185 case strat of

185 --create date examples graph for now- probably should be empty context in the future

186 --create date examples graph for now- probably should be empty context in the future

ProjectM36/DataTypes/Basic.hsnew file+14

@@ -0,0 +1,14 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+-- wraps up primitives plus other basic data types

3+module ProjectM36.DataTypes.Basic where

4+import ProjectM36.DataTypes.Primitive

5+import qualified Data.Map as M

6+import ProjectM36.Base

8+basicAtomTypes :: AtomTypes

9+basicAtomTypes = M.union primitiveAtomTypes moreTypes

10+ where

11+ moreTypes = M.fromList [("Day", (ConstructedAtomType "Day",

12+ AtomConstructor (M.singleton "Day" ["Int"])))]

13+

14+

ProjectM36/DataTypes/Day.hsnew file+18

@@ -0,0 +1,18 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.DataTypes.Day where

3+import ProjectM36.Base

4+import ProjectM36.DataTypes.Primitive

5+import ProjectM36.AtomFunctions.Primitive

6+import qualified Data.HashSet as HS

7+import Data.Time.Calendar

9+dayAtomType :: AtomType

10+dayAtomType = ConstructedAtomType "Day"

11+

12+dayFunctions :: AtomFunctions

13+dayFunctions = HS.fromList [

14+ AtomFunction { atomFuncName = "fromGregorian",

15+ atomFuncType = [intAtomType, intAtomType, intAtomType, dayAtomType],

16+ atomFunc = \(year:month:day:_) -> ConstructedAtom "Day" dayAtomType [Atom (fromGregorian (fromIntegral (unsafeCast year::Int)) (unsafeCast month) (unsafeCast day))]

17+ }

18+ ]

ProjectM36/DataTypes/Primitive.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module ProjectM36.DataTypes.Primitive where

3+import ProjectM36.Base

4+import Data.Proxy

5+import Data.Typeable

6+import ProjectM36.AtomConstructor

7+import ProjectM36.ConcreteTypeRep

8+import qualified Data.Map as M

9+import qualified Data.Text as T

10+import qualified Data.ByteString as BS

11+

12+atomTypeForProxy :: (Atomable a) => Proxy a -> AtomType

13+atomTypeForProxy prox = AtomType $ CTR (typeRep prox)

14+

15+textAtomType :: AtomType

16+textAtomType = atomTypeForProxy (Proxy :: Proxy T.Text)

17+

18+intAtomType :: AtomType

19+intAtomType = atomTypeForProxy (Proxy :: Proxy Int)

20+

21+boolAtomType :: AtomType

22+boolAtomType = atomTypeForProxy (Proxy :: Proxy Bool)

23+

24+doubleAtomType :: AtomType

25+doubleAtomType = atomTypeForProxy (Proxy :: Proxy Double)

26+

27+byteStringAtomType :: AtomType

28+byteStringAtomType = atomTypeForProxy (Proxy :: Proxy BS.ByteString)

29+

30+primitiveAtomTypes :: AtomTypes

31+primitiveAtomTypes = M.fromList $ map (\(typeName,typ) -> (typeName, (typ, emptyAtomConstructor))) prims

32+ where

33+ prims = [("Int", intAtomType),

34+ ("Text", textAtomType),

35+ ("Double", doubleAtomType),

36+ ("Bool", boolAtomType),

37+ ("ByteString", byteStringAtomType)

38+ ]

ProjectM36/DatabaseContext.hs+12

@@ -1,7 +1,11 @@

1+{-# LANGUAGE OverloadedStrings #-}

1module ProjectM36.DatabaseContext where

2module ProjectM36.DatabaseContext where

2import ProjectM36.Base

3import ProjectM36.Base

3import qualified Data.Map as M

4import qualified Data.Map as M

4import qualified Data.HashSet as HS

5import qualified Data.HashSet as HS

6+import ProjectM36.DataTypes.Basic

7+import ProjectM36.AtomFunctions.Basic

8+import ProjectM36.Relation

6empty :: DatabaseContext

10empty :: DatabaseContext

7empty = DatabaseContext { inclusionDependencies = M.empty,

11empty = DatabaseContext { inclusionDependencies = M.empty,

@@ -19,3 +23,11 @@ databaseContextAsDatabaseContextExpr context = MultipleExpr $ incDepsExprs ++ re

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

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

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

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

26+basicDatabaseContext :: DatabaseContext

27+basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

28+ relationVariables = M.fromList [("true", relationTrue),

29+ ("false", relationFalse)],

30+ atomFunctions = basicAtomFunctions,

31+ notifications = M.empty,

32+ atomTypes = basicAtomTypes

33+ }

ProjectM36/DateExamples.hsnew file+81

@@ -0,0 +1,81 @@

1+module ProjectM36.DateExamples where

2+import ProjectM36.Base

3+import ProjectM36.AtomFunctions.Basic

4+import ProjectM36.DataTypes.Basic

6+dateExamples :: DatabaseContext

7+dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

8+ relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

9+ notifications = M.empty,

10+ atomFunctions = basicAtomFunctions,

11+ atomTypes = basicAtomTypes }

12+ where

13+ dateRelVars = M.fromList [("S", suppliers),

14+ ("P", products),

15+ ("SP", supplierProducts)]

16+ suppliers = suppliersRel

17+ products = productsRel

18+ supplierProducts = supplierProductsRel

19+ dateIncDeps = M.fromList [("S_pkey", simplePKey ["S#"] "S"),

20+ ("P_pkey", simplePKey ["P#"] "P"),

21+ ("SP_pkey", simplePKey ["S#", "P#"] "SP")

22+ ]

23+ simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName)

24+

25+suppliersRel :: Relation

26+suppliersRel = case mkRelationFromList attrs atomMatrix of

27+ Left _ -> undefined

28+ Right rel -> rel

29+ where

30+ attrs = A.attributesFromList [Attribute "S#" textAtomType,

31+ Attribute "SNAME" textAtomType,

32+ Attribute "STATUS" intAtomType,

33+ Attribute "CITY" textAtomType]

34+ atomMatrix = [

35+ [textAtom "S1", textAtom "Smith", intAtom 20, textAtom "London"],

36+ [textAtom "S2", textAtom "Jones", intAtom 10, textAtom "Paris"],

37+ [textAtom "S3", textAtom "Blake", intAtom 30, textAtom "Paris"],

38+ [textAtom "S4", textAtom "Clark", intAtom 20, textAtom "London"],

39+ [textAtom "S5", textAtom "Adams", intAtom 30, textAtom "Athens"]]

40+

41+supplierProductsRel :: Relation

42+supplierProductsRel = case mkRelationFromList attrs matrix of

43+ Left _ -> undefined

44+ Right rel -> rel

45+ where

46+ attrs = A.attributesFromList [Attribute "S#" textAtomType,

47+ Attribute "P#" textAtomType,

48+ Attribute "QTY" intAtomType]

49+ matrix = [

50+ [textAtom "S1", textAtom "P1", intAtom 300],

51+ [textAtom "S1", textAtom "P2", intAtom 200],

52+ [textAtom "S1", textAtom "P3", intAtom 400],

53+ [textAtom "S1", textAtom "P4", intAtom 200],

54+ [textAtom "S1", textAtom "P5", intAtom 100],

55+ [textAtom "S1", textAtom "P6", intAtom 100],

56+ [textAtom "S2", textAtom "P1", intAtom 300],

57+ [textAtom "S2", textAtom "P2", intAtom 400],

58+ [textAtom "S3", textAtom "P2", intAtom 200],

59+ [textAtom "S4", textAtom "P2", intAtom 200],

60+ [textAtom "S4", textAtom "P4", intAtom 300],

61+ [textAtom "S4", textAtom "P5", intAtom 400]

62+ ]

63+

64+productsRel :: Relation

65+productsRel = case mkRelationFromList attrs matrix of

66+ Left _ -> undefined

67+ Right rel -> rel

68+ where

69+ attrs = A.attributesFromList [Attribute "P#" textAtomType,

70+ Attribute "PNAME" textAtomType,

71+ Attribute "COLOR" textAtomType,

72+ Attribute "WEIGHT" intAtomType,

73+ Attribute "CITY" textAtomType]

74+ matrix = [

75+ [textAtom "P1", textAtom "Nut", textAtom "Red", intAtom 12, textAtom "London"],

76+ [textAtom "P2", textAtom "Bolt", textAtom "Green", intAtom 17, textAtom "Paris"],

77+ [textAtom "P3", textAtom "Screw", textAtom "Blue", intAtom 17, textAtom "Oslo"],

78+ [textAtom "P4", textAtom "Screw", textAtom "Red", intAtom 14, textAtom "London"],

79+ [textAtom "P5", textAtom "Cam", textAtom "Blue", intAtom 12, textAtom "Paris"],

80+ [textAtom "P6", textAtom "Cog", textAtom "Red", intAtom 19, textAtom "London"]

81+ ]

ProjectM36/Error.hs+1

@@ -17,6 +17,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

17 | AttributeNamesMismatchError (S.Set AttributeName)

18 | AttributeNameInUseError AttributeName

19 | AttributeIsNotRelationValuedError AttributeName

20+ | CouldNotInferAttributes

20 | RelVarNotDefinedError RelVarName

21 | RelVarNotDefinedError RelVarName

21 | RelVarAlreadyDefinedError RelVarName

22 | RelVarAlreadyDefinedError RelVarName

22 | RelVarAssignmentTypeMismatchError Attributes Attributes --expected, found

23 | RelVarAssignmentTypeMismatchError Attributes Attributes --expected, found

ProjectM36/Relation.hs−37

@@ -4,15 +4,12 @@ import qualified Data.Set as S

4import qualified Data.HashSet as HS

5import Control.Monad

6import qualified Data.Vector as V

7−import ProjectM36.Atom

8−import Data.Typeable (cast)

9import ProjectM36.Base

7import ProjectM36.Base

10import ProjectM36.Tuple

8import ProjectM36.Tuple

11import qualified ProjectM36.Attribute as A

9import qualified ProjectM36.Attribute as A

12import qualified ProjectM36.AttributeNames as AS

10import qualified ProjectM36.AttributeNames as AS

13import ProjectM36.TupleSet

11import ProjectM36.TupleSet

14import ProjectM36.Error

12import ProjectM36.Error

15−import qualified Data.Text as T

16import qualified Control.Parallel.Strategies as P

13import qualified Control.Parallel.Strategies as P

17import Data.Either (isRight)

14import Data.Either (isRight)

@@ -260,39 +257,5 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe

260 tupleSetJoiner tup1 acc = undefined

257 tupleSetJoiner tup1 acc = undefined

261-}

258-}

262

259

263−-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long

264−-- this is useful for performance and resource usage testing

265−matrixRelation :: Int -> Int -> Either RelationalError Relation

266−matrixRelation attributeCount tupleCount = do

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

268− tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> Atom tupleX))

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

270− mkRelationDeferVerify attrs (RelationTupleSet tuples)

271−

272−

273−castInt :: Atom -> Int

274−castInt (ConstructedAtom _ _ _) = error "castInt attempt on ConstructedAtom"

275−castInt (Atom atom) = case cast atom of

276− Just i -> i

277− Nothing -> error "int cast failure" -- the type checker must ensure this can never occur

278−

279−--used by sum atom function

280−relationSum :: Relation -> Atom

281−relationSum relIn = Atom $ relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn

282− where

283− --extract Int from Atom

284− newVal :: RelationTuple -> Int

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

286−

287−relationCount :: Relation -> Atom

288−relationCount relIn = Atom $ relFold (\_ acc -> acc + 1) (0::Int) relIn

289

260

290−relationMax :: Relation -> Atom

291−relationMax relIn = Atom $ relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn

292− where

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

294

261

295−relationMin :: Relation -> Atom

296−relationMin relIn = Atom $ relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn

297− where

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

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

@@ -3,7 +3,8 @@ module ProjectM36.Relation.Show.Gnuplot where

3import ProjectM36.Base

4import ProjectM36.Relation

5import ProjectM36.Tuple

6−import ProjectM36.Atom

6+import ProjectM36.DataTypes.Primitive

7+import ProjectM36.AtomFunctions.Primitive

7import qualified ProjectM36.Attribute as A

8import qualified ProjectM36.Attribute as A

8import qualified Data.Vector as V

9import qualified Data.Vector as V

ProjectM36/Relation/Show/HTML.hs+2−4

@@ -3,6 +3,7 @@ module ProjectM36.Relation.Show.HTML where

3import ProjectM36.Base

4import ProjectM36.Relation

5import ProjectM36.Tuple

6+import ProjectM36.Atom

6import qualified Data.List as L

7import qualified Data.List as L

7import ProjectM36.Attribute

8import ProjectM36.Attribute

8import Data.Text (append, Text, pack)

9import Data.Text (append, Text, pack)

@@ -26,13 +27,10 @@ writeHTML = TIO.writeFile "/home/agentm/rel.html"

26writeRel :: Relation -> IO ()

27writeRel :: Relation -> IO ()

27writeRel = writeHTML . relationAsHTML

28writeRel = writeHTML . relationAsHTML

29−atomAsHTML :: Atom -> Text

30−atomAsHTML (Atom atom) = toText atom

31−

32tupleAsHTML :: RelationTuple -> Text

30tupleAsHTML :: RelationTuple -> Text

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

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

34 where

32 where

35− tupleFrag tup = "<td>" `append` atomAsHTML (snd tup) `append` "</td>"

33+ tupleFrag tup = "<td>" `append` atomToText (snd tup) `append` "</td>"

37tupleSetAsHTML :: RelationTupleSet -> Text

35tupleSetAsHTML :: RelationTupleSet -> Text

38tupleSetAsHTML tupSet = foldr folder "" (asList tupSet)

36tupleSetAsHTML tupSet = foldr folder "" (asList tupSet)

ProjectM36/RelationalExpression.hs+61−150

@@ -5,20 +5,19 @@ import ProjectM36.Tuple

5import ProjectM36.TupleSet

6import ProjectM36.Base

7import ProjectM36.Error

8−import ProjectM36.Atom

9import ProjectM36.AtomType

8import ProjectM36.AtomType

10−import ProjectM36.Key

9+import ProjectM36.DataTypes.Primitive

11import ProjectM36.AtomFunction

10import ProjectM36.AtomFunction

12−import ProjectM36.DataTypes.Interval

13import qualified ProjectM36.Attribute as A

11import qualified ProjectM36.Attribute as A

14import qualified Data.Map as M

12import qualified Data.Map as M

15import qualified Data.HashSet as HS

13import qualified Data.HashSet as HS

16−import qualified Data.Set as S

17import Control.Monad.State hiding (join)

14import Control.Monad.State hiding (join)

18import Data.Maybe

15import Data.Maybe

19import Data.Either

16import Data.Either

20import Data.Char (isUpper)

17import Data.Char (isUpper)

21import qualified Data.Text as T

18import qualified Data.Text as T

19+import qualified Data.Vector as V

20+--import Debug.Trace

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

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

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

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

@@ -56,7 +55,27 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do

56 case mkRelation attributeSet tupleSet of

55 case mkRelation attributeSet tupleSet of

57 Right rel -> return $ Right rel

56 Right rel -> return $ Right rel

58 Left err -> return $ Left err

57 Left err -> return $ Left err

59−

58+

59+evalRelationalExpr (MakeEmptyRelation attrExprs) = do

60+ currentContext <- get

61+ let eAttrs = map (evalAttrExpr (atomTypes currentContext)) attrExprs

62+ case lefts eAttrs of

63+ err:_ -> pure (Left err)

64+ [] -> pure $ mkRelation (A.attributesFromList (rights eAttrs)) emptyTupleSet

65+

66+evalRelationalExpr (MakeRelationFromTupleExprs tupleExprs) = do

67+ currentContext <- get

68+ if null tupleExprs then

69+ pure $ Left CouldNotInferAttributes

70+ else

71+ let eTuples = map (evalTupleExpr currentContext) tupleExprs in

72+ case lefts eTuples of

73+ err:_ -> pure (Left err)

74+ [] -> case head eTuples of

75+ Left err -> error $ "impossible Right err " ++ show err

76+ --extract potential attributes from first tuple

77+ Right firstTuple -> pure $ mkRelation (tupleAttributes firstTuple) (RelationTupleSet (rights eTuples))

78+

60evalRelationalExpr (ExistingRelation rel) = return (Right rel)

79evalRelationalExpr (ExistingRelation rel) = return (Right rel)

62evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

81evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

@@ -112,7 +131,7 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do

112 case evald of

131 case evald of

113 Left err -> return $ Left err

132 Left err -> return $ Left err

114 Right rel -> do

133 Right rel -> do

115− case tupleExpressionProcessor rel tupleExpression context of

134+ case extendTupleExpressionProcessor rel tupleExpression context of

116 Left err -> return $ Left err

135 Left err -> return $ Left err

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

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

118

137

@@ -124,91 +143,7 @@ emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

124 atomTypes = M.empty

143 atomTypes = M.empty

125 }

144 }

126

145

127−basicDatabaseContext :: DatabaseContext

128−basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

129− relationVariables = M.fromList [("true", relationTrue),

130− ("false", relationFalse)],

131− atomFunctions = basicAtomFunctions,

132− notifications = M.empty,

133− atomTypes = basicAtomTypes

134− }

135

146

136−dateExamples :: DatabaseContext

137−dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

138− relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

139− notifications = M.empty,

140− atomFunctions = basicAtomFunctions,

141− atomTypes = basicAtomTypes }

142− where

143− dateRelVars = M.fromList [("S", suppliers),

144− ("P", products),

145− ("SP", supplierProducts)]

146− suppliers = suppliersRel

147− products = productsRel

148− supplierProducts = supplierProductsRel

149− dateIncDeps = M.fromList [("S_pkey", simplePKey ["S#"] "S"),

150− ("P_pkey", simplePKey ["P#"] "P"),

151− ("SP_pkey", simplePKey ["S#", "P#"] "SP")

152− ]

153− simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName)

154−

155−suppliersRel :: Relation

156−suppliersRel = case mkRelationFromList attrs atomMatrix of

157− Left _ -> undefined

158− Right rel -> rel

159− where

160− attrs = A.attributesFromList [Attribute "S#" stringAtomType,

161− Attribute "SNAME" stringAtomType,

162− Attribute "STATUS" intAtomType,

163− Attribute "CITY" stringAtomType]

164− atomMatrix = [

165− [stringAtom "S1", stringAtom "Smith", intAtom 20, stringAtom "London"],

166− [stringAtom "S2", stringAtom "Jones", intAtom 10, stringAtom "Paris"],

167− [stringAtom "S3", stringAtom "Blake", intAtom 30, stringAtom "Paris"],

168− [stringAtom "S4", stringAtom "Clark", intAtom 20, stringAtom "London"],

169− [stringAtom "S5", stringAtom "Adams", intAtom 30, stringAtom "Athens"]]

170−

171−supplierProductsRel :: Relation

172−supplierProductsRel = case mkRelationFromList attrs matrix of

173− Left _ -> undefined

174− Right rel -> rel

175− where

176− attrs = A.attributesFromList [Attribute "S#" stringAtomType,

177− Attribute "P#" stringAtomType,

178− Attribute "QTY" intAtomType]

179− matrix = [

180− [stringAtom "S1", stringAtom "P1", intAtom 300],

181− [stringAtom "S1", stringAtom "P2", intAtom 200],

182− [stringAtom "S1", stringAtom "P3", intAtom 400],

183− [stringAtom "S1", stringAtom "P4", intAtom 200],

184− [stringAtom "S1", stringAtom "P5", intAtom 100],

185− [stringAtom "S1", stringAtom "P6", intAtom 100],

186− [stringAtom "S2", stringAtom "P1", intAtom 300],

187− [stringAtom "S2", stringAtom "P2", intAtom 400],

188− [stringAtom "S3", stringAtom "P2", intAtom 200],

189− [stringAtom "S4", stringAtom "P2", intAtom 200],

190− [stringAtom "S4", stringAtom "P4", intAtom 300],

191− [stringAtom "S4", stringAtom "P5", intAtom 400]

192− ]

193−

194−productsRel :: Relation

195−productsRel = case mkRelationFromList attrs matrix of

196− Left _ -> undefined

197− Right rel -> rel

198− where

199− attrs = A.attributesFromList [Attribute "P#" stringAtomType,

200− Attribute "PNAME" stringAtomType,

201− Attribute "COLOR" stringAtomType,

202− Attribute "WEIGHT" intAtomType,

203− Attribute "CITY" stringAtomType]

204− matrix = [

205− [stringAtom "P1", stringAtom "Nut", stringAtom "Red", intAtom 12, stringAtom "London"],

206− [stringAtom "P2", stringAtom "Bolt", stringAtom "Green", intAtom 17, stringAtom "Paris"],

207− [stringAtom "P3", stringAtom "Screw", stringAtom "Blue", intAtom 17, stringAtom "Oslo"],

208− [stringAtom "P4", stringAtom "Screw", stringAtom "Red", intAtom 14, stringAtom "London"],

209− [stringAtom "P5", stringAtom "Cam", stringAtom "Blue", intAtom 12, stringAtom "Paris"],

210− [stringAtom "P6", stringAtom "Cog", stringAtom "Red", intAtom 19, stringAtom "London"]

211− ]

212

147

213--helper function to process relation variable creation/assignment

148--helper function to process relation variable creation/assignment

214setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)

149setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)

@@ -231,13 +166,18 @@ deleteRelVar relVarName = do

231 return Nothing

166 return Nothing

232

167

233evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)

168evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)

234−evalContextExpr (Define relVarName attrs) = do

169+evalContextExpr (Define relVarName attrExprs) = do

235 relvars <- liftM relationVariables get

170 relvars <- liftM relationVariables get

171+ aTypes <- liftM atomTypes get

172+ let eAttrs = map (evalAttrExpr aTypes) attrExprs

173+ case lefts eAttrs of

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

236− case M.member relVarName relvars of

175+ [] -> case M.member relVarName relvars of

237− True -> return (Just (RelVarAlreadyDefinedError relVarName))

176+ True -> return (Just (RelVarAlreadyDefinedError relVarName))

238− False -> setRelVar relVarName emptyRelation

177+ False -> setRelVar relVarName emptyRelation

239− where

178+ where

179+ attrs = A.attributesFromList (rights eAttrs)

240− emptyRelation = Relation attrs emptyTupleSet

180+ emptyRelation = Relation attrs emptyTupleSet

241

181

242evalContextExpr (Undefine relVarName) = do

182evalContextExpr (Undefine relVarName) = do

243 deleteRelVar relVarName

183 deleteRelVar relVarName

@@ -335,16 +275,18 @@ evalContextExpr (RemoveNotification notName) = do

335

275

336-- | Adds type and data constructors to the database context.

276-- | Adds type and data constructors to the database context.

337-- validate that the type *and* constructor names are unique! not yet implemented!

277-- validate that the type *and* constructor names are unique! not yet implemented!

338−evalContextExpr (AddAtomConstructor tConsName atomConstructor) = do

278+evalContextExpr (AddAtomConstructor tConsName atomC@(AtomConstructor atomConsMap)) = do

339 currentContext <- get

279 currentContext <- get

340 let oldAtomTypes = atomTypes currentContext

280 let oldAtomTypes = atomTypes currentContext

281+ -- validate that the constructor's types exist

282+ -- atomAndArgsTypesForDataConstructorName oldAtomTypes

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

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

342 pure $ Just (InvalidAtomTypeName tConsName)

284 pure $ Just (InvalidAtomTypeName tConsName)

343 else if M.member tConsName oldAtomTypes then

285 else if M.member tConsName oldAtomTypes then

344 pure $ Just (AtomTypeNameInUseError tConsName)

286 pure $ Just (AtomTypeNameInUseError tConsName)

345 else do

287 else do

346 let newAtomTypes = M.insert tConsName newType oldAtomTypes

288 let newAtomTypes = M.insert tConsName newType oldAtomTypes

347− newType = (ConstructedAtomType tConsName, atomConstructor)

289+ newType = (ConstructedAtomType tConsName, atomC)

348 put $ currentContext { atomTypes = newAtomTypes }

290 put $ currentContext { atomTypes = newAtomTypes }

349 pure Nothing

291 pure Nothing

350

292

@@ -475,8 +417,8 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName

475 else

417 else

476 Right rel

418 Right rel

477

419

478−tupleExpressionProcessor :: Relation -> TupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)

420+extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)

479−tupleExpressionProcessor relIn

421+extendTupleExpressionProcessor relIn

480 (AttributeExtendTupleExpr newAttrName atomExpr) context = do

422 (AttributeExtendTupleExpr newAttrName atomExpr) context = do

481 _ <- tupleExprCheckNewAttrName newAttrName relIn

423 _ <- tupleExprCheckNewAttrName newAttrName relIn

482 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr

424 atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr

@@ -525,7 +467,7 @@ typeFromAtomExpr attrs context (ConstructedAtomExpr dConsName dConsArgs) = do

525 else

467 else

526 pure tConsType

468 pure tConsType

527

469

528−-- | Validae that the

470+-- | Validate that the type of the AtomExpr matches the expected type.

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

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

530verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do

472verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do

531 attrType <- A.atomTypeForAttributeName attrName (attributes relIn)

473 attrType <- A.atomTypeForAttributeName attrName (attributes relIn)

@@ -553,52 +495,21 @@ verifyAtomExprTypes rel context cons@(ConstructedAtomExpr _ _) expectedType = do

553 atomTypeVerify expectedType cType

495 atomTypeVerify expectedType cType

554

496

555

497

556−

498+-- | Look up the type's name and create a new attribute.

557−basicAtomFunctions :: AtomFunctions

499+evalAttrExpr :: AtomTypes -> AttributeExpr -> Either RelationalError Attribute

558−basicAtomFunctions = HS.fromList $ [

500+evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tConsName) = do

559− --match on any relation type

501+ aType <- atomTypeForTypeConstructor tConsName aTypes

560− AtomFunction { atomFuncName = "add",

502+ Right (Attribute attrName aType)

561− atomFuncType = [intAtomType, intAtomType, intAtomType],

503+

562− atomFunc = (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},

504+evalTupleExpr :: DatabaseContext -> TupleExpr -> Either RelationalError RelationTuple

563− AtomFunction { atomFuncName = "id",

505+evalTupleExpr context (TupleExpr tupMap) = do

564− atomFuncType = [AnyAtomType, AnyAtomType],

506+ -- 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

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

507+ attrAtoms <- mapM (\(attrName, aExpr) -> do

566− AtomFunction { atomFuncName = "sum",

508+ newAtom <- evalAtomExpr emptyTuple context aExpr

567− atomFuncType = foldAtomFuncType intAtomType intAtomType,

509+ newAtomType <- typeFromAtomExpr A.emptyAttributes context aExpr

568− atomFunc = (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},

510+ pure (attrName, newAtom, newAtomType)

569− AtomFunction { atomFuncName = "count",

511+ ) (M.toList tupMap)

570− atomFuncType = foldAtomFuncType AnyAtomType intAtomType,

512+ let attrs = map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms

571− atomFunc = (\((relIn):_) -> relationCount (castRelation relIn))},

513+ atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms

572− AtomFunction { atomFuncName = "max",

514+ pure $ mkRelationTuple (A.attributesFromList attrs) atoms

573− atomFuncType = foldAtomFuncType intAtomType intAtomType,

515+

574− atomFunc = (\((relIn):_) -> relationMax (castRelation relIn))},

575− AtomFunction { atomFuncName = "min",

576− atomFuncType = foldAtomFuncType intAtomType intAtomType,

577− atomFunc = (\((relIn):_) -> relationMin (castRelation relIn))},

578− AtomFunction { atomFuncName = "lt",

579− atomFuncType = [intAtomType, intAtomType, boolAtomType],

580− atomFunc = intAtomFuncLessThan False},

581− AtomFunction { atomFuncName = "lte",

582− atomFuncType = [intAtomType, intAtomType, boolAtomType],

583− atomFunc = intAtomFuncLessThan True},

584− AtomFunction { atomFuncName = "gte",

585− atomFuncType = [intAtomType, intAtomType, boolAtomType],

586− atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},

587− AtomFunction { atomFuncName = "gt",

588− atomFuncType = [intAtomType, intAtomType, boolAtomType],

589− atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},

590− AtomFunction { atomFuncName = "not",

591− atomFuncType = [boolAtomType, boolAtomType],

592− atomFunc = boolAtomNot}

593− ] ++ intervalFunctions

594−

595−intAtomFuncLessThan :: Bool -> [Atom] -> Atom

596−intAtomFuncLessThan equality (iatom1:iatom2:_) = (\i1 i2 -> Atom $ ((unsafeCast i1)::Int) `op` unsafeCast i2) iatom1 iatom2

597− where

598− op = if equality then (<=) else (<)

599−intAtomFuncLessThan _ _= Atom False

600−

601−boolAtomNot :: [Atom] -> Atom

602−boolAtomNot (bool:_) = Atom $ not (unsafeCast bool)

603−boolAtomNot _ = Atom False

604−

ProjectM36/Sessions.hs+5−4

@@ -5,8 +5,9 @@ import qualified STMContainers.Map as STMMap

5import ListT

6import ProjectM36.Attribute

7import ProjectM36.Base

8−import ProjectM36.Atom

8+import ProjectM36.DataTypes.Primitive

9import ProjectM36.Session

10+import ProjectM36.Atom

10import ProjectM36.Relation

11import ProjectM36.Relation

11import ProjectM36.Error

12import ProjectM36.Error

12import qualified Data.UUID as U

13import qualified Data.UUID as U

@@ -17,13 +18,13 @@ stmMapToList :: STMMap.Map k v -> STM [(k, v)]

17stmMapToList = ListT.fold (\l -> return . (:l)) [] . STMMap.stream

18stmMapToList = ListT.fold (\l -> return . (:l)) [] . STMMap.stream

19uuidAtom :: U.UUID -> Atom

20uuidAtom :: U.UUID -> Atom

20−uuidAtom = stringAtom . U.toText

21+uuidAtom = textAtom . U.toText

22sessionsAsRelation :: Sessions -> STM (Either RelationalError Relation)

23sessionsAsRelation :: Sessions -> STM (Either RelationalError Relation)

23sessionsAsRelation sessions = do

24sessionsAsRelation sessions = do

24 sessionAssocs <- stmMapToList sessions

25 sessionAssocs <- stmMapToList sessions

25 let atomMatrix = map (\(sessionId, (Session (DisconnectedTransaction parentUUID _))) -> [uuidAtom sessionId, uuidAtom parentUUID]) sessionAssocs

26 let atomMatrix = map (\(sessionId, (Session (DisconnectedTransaction parentUUID _))) -> [uuidAtom sessionId, uuidAtom parentUUID]) sessionAssocs

26− pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" stringAtomType,

27+ pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" textAtomType,

27− Attribute "parentCommit" stringAtomType]) atomMatrix

28+ Attribute "parentCommit" textAtomType]) atomMatrix

ProjectM36/StaticOptimizer.hs+7

@@ -15,8 +15,12 @@ import Data.Either (rights, lefts)

15applyStaticRelationalOptimization :: RelationalExpr -> DatabaseState (Either RelationalError RelationalExpr)

16applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = return $ Right e

18+applyStaticRelationalOptimization e@(MakeRelationFromTupleExprs _) = return $ Right e

19+

18applyStaticRelationalOptimization e@(ExistingRelation _) = return $ Right e

20applyStaticRelationalOptimization e@(ExistingRelation _) = return $ Right e

22+applyStaticRelationalOptimization e@(MakeEmptyRelation _) = return $ Right e

23+

20applyStaticRelationalOptimization e@(RelationVariable _) = return $ Right e

24applyStaticRelationalOptimization e@(RelationVariable _) = return $ Right e

22--remove project of attributes which removes no attributes

26--remove project of attributes which removes no attributes

@@ -133,6 +137,9 @@ applyStaticDatabaseOptimization (AddNotification name triggerExpr resultExpr) =

133

137

134applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right notif)

138applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right notif)

135

139

140+applyStaticDatabaseOptimization c@(AddAtomConstructor _ _) = pure (Right c)

141+applyStaticDatabaseOptimization c@(RemoveAtomConstructor _) = pure (Right c)

142+

136--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

143--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

137

144

138--applyStaticDatabaseOptimization (MultipleExpr exprs) = return $ Right $ MultipleExpr exprs

145--applyStaticDatabaseOptimization (MultipleExpr exprs) = return $ Right $ MultipleExpr exprs

ProjectM36/Transaction/Persist.hs+16−2

@@ -11,7 +11,7 @@ import System.FilePath

11import System.Directory

12import qualified Data.Text as T

13import Control.Monad

14−import ProjectM36.RelationalExpression (basicAtomFunctions)

14+import ProjectM36.AtomFunctions.Basic (basicAtomFunctions)

16getDirectoryNames :: FilePath -> IO [FilePath]

17getDirectoryNames path = do

@@ -36,6 +36,9 @@ incDepsDir transdir = transdir </> "incdeps"

36atomFuncsDir :: FilePath -> FilePath

37atomFuncsDir transdir = transdir </> "atomfuncs"

39+atomTypesPath :: FilePath -> FilePath

40+atomTypesPath transdir = transdir </> "atomtypes"

41+

39readTransaction :: FilePath -> U.UUID -> IO (Either PersistenceError Transaction)

42readTransaction :: FilePath -> U.UUID -> IO (Either PersistenceError Transaction)

40readTransaction dbdir transUUID = do

43readTransaction dbdir transUUID = do

41 let transDir = transactionDir dbdir transUUID

44 let transDir = transactionDir dbdir transUUID

@@ -46,10 +49,12 @@ readTransaction dbdir transUUID = do

46 relvars <- readRelVars transDir

49 relvars <- readRelVars transDir

47 transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)

50 transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)

48 incDeps <- readIncDeps transDir

51 incDeps <- readIncDeps transDir

52+ atomtypes <- readAtomTypes transDir

49 --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet

53 --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet

50 let atomFuncs = basicAtomFunctions

54 let atomFuncs = basicAtomFunctions

51 let newContext = DatabaseContext { inclusionDependencies = incDeps,

55 let newContext = DatabaseContext { inclusionDependencies = incDeps,

52 relationVariables = relvars,

56 relationVariables = relvars,

57+ atomTypes = atomtypes,

53 notifications = M.empty,

58 notifications = M.empty,

54 atomFunctions = atomFuncs }

59 atomFunctions = atomFuncs }

@@ -67,6 +72,7 @@ writeTransaction sync dbdir trans = do

67 writeRelVars sync tempTransDir (relationVariables context)

72 writeRelVars sync tempTransDir (relationVariables context)

68 writeIncDeps sync tempTransDir (inclusionDependencies context)

73 writeIncDeps sync tempTransDir (inclusionDependencies context)

69 writeAtomFuncs sync tempTransDir (atomFunctions context)

74 writeAtomFuncs sync tempTransDir (atomFunctions context)

75+ writeAtomTypes sync tempTransDir (atomTypes context)

70 BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)

76 BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)

71 --move the temp directory to final location

77 --move the temp directory to final location

72 renameSync sync tempTransDir finalTransDir

78 renameSync sync tempTransDir finalTransDir

@@ -130,4 +136,12 @@ readIncDeps transDir = do

130 let incDepsPath = incDepsDir transDir

136 let incDepsPath = incDepsDir transDir

131 incDepNames <- getDirectoryNames incDepsPath

137 incDepNames <- getDirectoryNames incDepsPath

132 incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)

138 incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)

133− return $ M.fromList incDeps

139+ return $ M.fromList incDeps

140+

141+writeAtomTypes :: DiskSync -> FilePath -> AtomTypes -> IO ()

142+writeAtomTypes sync path aTypes = writeBSFileSync sync path $ B.encode aTypes

143+

144+readAtomTypes :: FilePath -> IO (AtomTypes)

145+readAtomTypes path = do

146+ let atPath = atomTypesPath path

147+ liftM B.decode (BS.readFile atPath)

ProjectM36/TransactionGraph.hs+5−5

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

6import ProjectM36.Relation

7import ProjectM36.TupleSet

8import ProjectM36.Tuple

9−import ProjectM36.Atom

9+import ProjectM36.DataTypes.Primitive

10import qualified Data.Vector as V

11import qualified ProjectM36.Attribute as A

12import qualified Data.UUID as U

@@ -213,12 +213,12 @@ graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _

213 tupleMatrix <- mapM tupleGenerator (S.toList transSet)

214 mkRelationFromList attrs tupleMatrix

215 where

216− attrs = A.attributesFromList [Attribute "id" stringAtomType,

216+ attrs = A.attributesFromList [Attribute "id" textAtomType,

217 Attribute "parents" (RelationAtomType parentAttributes),

218 Attribute "current" boolAtomType,

219− Attribute "head" stringAtomType

219+ Attribute "head" textAtomType

220 ]

221− parentAttributes = A.attributesFromList [Attribute "id" stringAtomType]

221+ parentAttributes = A.attributesFromList [Attribute "id" textAtomType]

222 tupleGenerator transaction = case transactionParentsRelation transaction graph of

223 Left err -> Left err

224 Right parentTransRel -> Right [Atom $ T.pack $ show (transactionUUID transaction),

@@ -238,7 +238,7 @@ transactionParentsRelation trans graph = do

238 let tuples = map trans2tuple (S.toList parentTransSet)

239 mkRelationFromTuples attrs tuples

240 where

241− attrs = A.attributesFromList [Attribute "id" stringAtomType]

241+ attrs = A.attributesFromList [Attribute "id" textAtomType]

242 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (Atom (T.pack (show $ transactionUUID trans2)))

243

244{-

TutorialD/Interpreter/Base.hs+5−3

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

10import qualified Data.Vector as V

11import qualified Data.Text.IO as TIO

12import System.IO

13−import ProjectM36.Atom

13+import ProjectM36.DataTypes.Primitive

15lexer :: Token.TokenParser ()

16lexer = Token.makeTokenParser tutD

@@ -39,6 +39,9 @@ identifier = Token.identifier lexer

39comma :: Parser String

40comma = Token.comma lexer

42+pipe :: Parser String

43+pipe = Token.symbol lexer "|"

44+

42semi :: Parser String

45semi :: Parser String

43semi = Token.semi lexer

46semi = Token.semi lexer

@@ -53,10 +56,9 @@ float = Token.float lexer

54atomTypeToTutDType :: AtomType -> Maybe T.Text

57atomTypeToTutDType :: AtomType -> Maybe T.Text

55atomTypeToTutDType atomType = case atomType of

58atomTypeToTutDType atomType = case atomType of

56− aType@(AtomType _) -> lookup aType [(stringAtomType, "char"),

59+ aType@(AtomType _) -> lookup aType [(textAtomType, "char"),

57 (intAtomType, "int"),

60 (intAtomType, "int"),

58 (boolAtomType, "bool"),

61 (boolAtomType, "bool"),

59− (dateTimeAtomType, "datetime"),

60 (doubleAtomType, "double")]

62 (doubleAtomType, "double")]

61 (RelationAtomType attrs) -> Just $ "relation" `T.append` showRelationAttributes attrs

63 (RelationAtomType attrs) -> Just $ "relation" `T.append` showRelationAttributes attrs

62 _ -> Nothing

64 _ -> Nothing

TutorialD/Interpreter/DatabaseExpr.hs+2−2

@@ -56,7 +56,7 @@ defineP = do

56 relVarName <- identifier

57 reservedOp "::"

58 return relVarName

59− attributeSet <- makeAttributesP

59+ attributeSet <- makeAttributeExprsP

60 return $ Define (T.pack relVarName) attributeSet

62undefineP :: Parser DatabaseExpr

@@ -132,7 +132,7 @@ addAtomConstructorP = do

132 reserved "data"

133 typeConstructorName <- identifier

134 reservedOp "="

135− dataConstructors <- sepBy1 dataConstructorP comma

135+ dataConstructors <- sepBy1 dataConstructorP pipe

136 let aCons = AtomConstructor (M.fromList dataConstructors)

137 pure (AddAtomConstructor (T.pack typeConstructorName) aCons)

138

TutorialD/Interpreter/RelationalExpr.hs+24−106

@@ -5,36 +5,15 @@ import ProjectM36.Base

5import Text.Parsec.String

6import TutorialD.Interpreter.Base

7import qualified Data.Text as T

8−import qualified ProjectM36.Attribute as A

9−import ProjectM36.TupleSet

10−import ProjectM36.Tuple

11−import ProjectM36.Relation

12−import ProjectM36.Atom

13−import qualified Data.Vector as V

14import qualified Data.Set as S

8import qualified Data.Set as S

9+import qualified Data.Map as M

15import Data.Functor.Identity (Identity)

10import Data.Functor.Identity (Identity)

16import Data.Time.Format

11import Data.Time.Format

17import Control.Applicative (liftA)

12import Control.Applicative (liftA)

18import Data.ByteString.Base64 as B64

13import Data.ByteString.Base64 as B64

19import Data.Text.Encoding as TE

14import Data.Text.Encoding as TE

20−import TutorialD.Interpreter.DataTypes.DateTime

21−import TutorialD.Interpreter.DataTypes.Interval

22−

23import Data.Time.Calendar (Day)

15import Data.Time.Calendar (Day)

25−--nuke this

26−{-

27−atomTypeP :: Parser AtomType

28−atomTypeP = (reserved "char" *> return stringAtomType) <|>

29− (reserved "int" *> return intAtomType) <|>

30− (reserved "datetime" *> return dateTimeAtomType) <|>

31− (reserved "date" *> return dateAtomType) <|>

32− (reserved "double" *> return doubleAtomType) <|>

33− (reserved "bool" *> return boolAtomType) <|>

34− (reserved "bytestring" *> return byteStringAtomType) <|>

35− (RelationAtomType <$> (reserved "relation" *> makeAttributesP))

36−-}

37−

38--used in projection

17--used in projection

39attributeListP :: Parser AttributeNames

18attributeListP :: Parser AttributeNames

40attributeListP = do

19attributeListP = do

@@ -46,40 +25,29 @@ attributeListP = do

46makeRelationP :: Parser RelationalExpr

25makeRelationP :: Parser RelationalExpr

47makeRelationP = do

26makeRelationP = do

48 reserved "relation"

27 reserved "relation"

49− attrs <- (try makeAttributesP <|> return A.emptyAttributes)

28+ attrExprs <- (try makeAttributeExprsP <|> pure [])

50− if not (A.null attrs) then do

29+ if not (null attrExprs) then do

51− case mkRelation attrs emptyTupleSet of

30+ pure $ MakeEmptyRelation attrExprs

52− Left err -> fail (show err)

53− Right rel -> pure (ExistingRelation rel)

54− else do -- empty attributes

31+ else do -- empty attributes, assume tuple expressions

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

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

56− pure $ MakeRelationFromAtomExprs attrs

33+ pure $ MakeRelationFromTupleExprs tupleExprs

57−

58−

59−makeAttributeExprsP :: Parser [AttributeExpr]

60−makeAttributeExprsP = do

61− attrList <- bra

63--used in relation creation

35--used in relation creation

64−makeAttributeExprsP :: Parser [AttributeExprs]

36+makeAttributeExprsP :: Parser [AttributeExpr]

65−makeAttributeExprsP = do

66− attrList <- braces (sepBy attributeAndTypeNameP comma)

37+makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)

67− return $ A.attributesFromList attrList

68−

70attributeAndTypeNameP :: Parser AttributeExpr

39attributeAndTypeNameP :: Parser AttributeExpr

71attributeAndTypeNameP = do

40attributeAndTypeNameP = do

72 attrName <- identifier

41 attrName <- identifier

73 --convert type name into type

42 --convert type name into type

74 atomType <- identifier

43 atomType <- identifier

75− return $ AttributeAndTypeNameExpr (T.pack attrName) atomType

44+ return $ AttributeAndTypeNameExpr (T.pack attrName) (T.pack atomType)

77tupleExprP :: Parser TupleExpr

46tupleExprP :: Parser TupleExpr

78tupleExprP = do

47tupleExprP = do

79 reservedOp "tuple"

48 reservedOp "tuple"

80 attrAssocs <- braces (sepBy tupleAtomExprP comma)

49 attrAssocs <- braces (sepBy tupleAtomExprP comma)

81− let attrs = A.attributesFromList $ map fst attrAssocs

82− pure (TupleExpr attrs (map snd attrAssocs))

50+ pure (TupleExpr (M.fromList attrAssocs))

84tupleAtomExprP :: Parser (AttributeName, AtomExpr)

52tupleAtomExprP :: Parser (AttributeName, AtomExpr)

85tupleAtomExprP = do

53tupleAtomExprP = do

@@ -137,33 +105,6 @@ extendP = do

137 tupleExpr <- braces extendTupleExpressionP

105 tupleExpr <- braces extendTupleExpressionP

138 return $ Extend tupleExpr

106 return $ Extend tupleExpr

139

107

140−{-

141−rewrite summarize as extend as evaluate

142−it turns out that summarize must be a relational expression primitive because it requires

143−

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

145−so, in general,

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

147−-}

148−{-

149−summarizeP :: Parser (RelationalExpr -> RelationalExpr)

150−summarizeP = do

151− reservedOp "per"

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

153− perExpr <- parens relExpr

154− reservedOp "add"

155− (funcAtomExpr, newAttrName) <- parens summaryP

156− --rewrite summarize as extend

157− --return $ Summarize funcAtomExpr newAttrName perExpr

158−

159−summaryP :: Parser (AtomExpr, AttributeName)

160−summaryP = do

161− expr <- atomExprP

162− reserved "as"

163− attrName <- identifier

164− return (expr, T.pack attrName)

165−-}

166−

167relOperators :: [[Operator String () Identity RelationalExpr]]

108relOperators :: [[Operator String () Identity RelationalExpr]]

168relOperators = [

109relOperators = [

169 [Postfix projectP],

110 [Postfix projectP],

@@ -234,10 +175,10 @@ attributeExtendTupleExpressionP = do

234

175

235atomExprP :: Parser AtomExpr

176atomExprP :: Parser AtomExpr

236atomExprP = try functionAtomExprP <|>

177atomExprP = try functionAtomExprP <|>

178+ try constructedAtomExprP <|>

237− attributeAtomExprP <|>

179+ attributeAtomExprP <|>

238− nakedAtomExprP <|>

180+ nakedAtomExprP <|>

239− relationalAtomExprP <|>

181+ relationalAtomExprP

240− constructedAtomP

241

182

242attributeAtomExprP :: Parser AtomExpr

183attributeAtomExprP :: Parser AtomExpr

243attributeAtomExprP = do

184attributeAtomExprP = do

@@ -249,26 +190,20 @@ nakedAtomExprP :: Parser AtomExpr

249nakedAtomExprP = NakedAtomExpr <$> atomP

190nakedAtomExprP = NakedAtomExpr <$> atomP

250

191

251-- | Uses square brackets for TutorialD support.

192-- | Uses square brackets for TutorialD support.

252−constructedAtomP :: Parser AtomExpr

193+constructedAtomExprP :: Parser AtomExpr

253−constructedAtomP = do

194+constructedAtomExprP = do

254− reserved "["

255− dConsName <- identifier

195+ dConsName <- identifier

196+ _ <- char '['

256− dConsArgs <- sepBy atomExprP spaces

197+ dConsArgs <- sepBy atomExprP comma

257− reserved "]"

198+ _ <- char ']'

258 pure $ ConstructedAtomExpr (T.pack dConsName) dConsArgs

199 pure $ ConstructedAtomExpr (T.pack dConsName) dConsArgs

259

200

201+-- used only for primitive type parsing ?

260atomP :: Parser Atom

202atomP :: Parser Atom

261−atomP = dateTimeAtomP <|>

262− intervalDateTimeAtomP <|>

263− dateAtomP <|>

264− maybeTextAtomP <|>

265− maybeIntAtomP <|>

266− byteStringAtomP <|>

267− stringAtomP <|>

203+atomP = stringAtomP <|>

268 doubleAtomP <|>

204 doubleAtomP <|>

269 intAtomP <|>

205 intAtomP <|>

270− boolAtomP <|>

206+ boolAtomP

271− relationAtomP

272

207

273functionAtomExprP :: Parser AtomExpr

208functionAtomExprP :: Parser AtomExpr

274functionAtomExprP = do

209functionAtomExprP = do

@@ -321,7 +256,7 @@ boolAtomP = do

321 return $ Atom (val == 't')

256 return $ Atom (val == 't')

322

257

323relationAtomExprP :: Parser AtomExpr

258relationAtomExprP :: Parser AtomExpr

324−relationAtomExprP = RelationAtomExpr <$> relationExprP

259+relationAtomExprP = RelationAtomExpr <$> makeRelationP

325

260

326-- deprecated for removal- use constructors

261-- deprecated for removal- use constructors

327byteStringAtomP :: Parser Atom

262byteStringAtomP :: Parser Atom

@@ -334,20 +269,3 @@ byteStringAtomP = do

334 Left err -> fail err

269 Left err -> fail err

335 Right bsVal -> return $ Atom bsVal

270 Right bsVal -> return $ Atom bsVal

336

271

337−{-

338−--relation constructor -- no choice but to propagate relation-construction errors as parse errors. Perhaps this could be improved in the future

339−relationP :: Parser Relation

340−relationP = do

341− reserved "relation"

342− attrs <- (try makeAttributesP <|> return A.emptyAttributes)

343− if not (A.null attrs) then do

344− case mkRelation attrs emptyTupleSet of

345− Left err -> fail (show err)

346− Right rel -> return rel

347− else do -- empty attributes

348− tuples <- try (braces (sepBy tupleP comma)) <|> pure []

349− let tupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

350− case mkRelationFromTuples tupleAttrs tuples of

351− Left err -> fail (show err)

352− Right rel -> return rel

353−-}

benchmark/bigrel.hs+10

@@ -92,3 +92,13 @@ vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tu

93instance Hash.Hashable (V.Vector Atom) where

94 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)

95+

96+-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long

97+-- this is useful for performance and resource usage testing

98+matrixRelation :: Int -> Int -> Either RelationalError Relation

99+matrixRelation attributeCount tupleCount = do

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

101+ tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> Atom tupleX))

102+ tuples = map (\c -> tuple c) [0 .. tupleCount]

103+ mkRelationDeferVerify attrs (RelationTupleSet tuples)

104+