9f743ca · project-m36 · git.iko.soy

docs/tutd_tutorial.markdown+7−3

compare with master

unifiedsplit

@@ -20,15 +20,19 @@ TutorialD is strongly-typed. The basic built-in types are:

20

21|Type Name|Explanation|Example|

22|---------|-----------|-------|

23−|char|arbitrary text|"The Old Man and the Sea"|

23+|text|arbitrary text|"The Old Man and the Sea"|

24|int|any integer|-4|

25−|datetime|timestamp UTC|"2015-02-02 04:05:02"::datetime|

25+|datetime|timestamp UTC|dateTimeFromEpochSeconds(1502304846)|

26+|date|calendar date|fromGregorian(2017,05,30)|

26|double|floating point number|3.1459|

27|double|floating point number|3.1459|

27|bool|boolean value|t|

28|bool|boolean value|t|

28−|bytestring|arbitrary-length string of bytes- input is base64-encoded|"dGVzdGRhdGE="::bytestring|

29+|bytestring|arbitrary-length string of bytes- input is base64-encoded|bytestring("dGVzdGRhdGE=")|

30+|interval x|interval/range type for ints, doubles, datetimes, and dates|interval(3,5,f,f)|

29

31

30With regards to boolean values, be sure not to conflate ```t``` or ```f``` as a boolean value with ```true``` and ```false``` which are relation variables.

32With regards to boolean values, be sure not to conflate ```t``` or ```f``` as a boolean value with ```true``` and ```false``` which are relation variables.

31

33

34+The ```interval``` function last two arguments are boolean values indicating whether the interval is open at the start point and end point respectively.

35+

32Project:M36 will complain loudly if the expected types do not match. Automatic type coercion does not exist.

36Project:M36 will complain loudly if the expected types do not match. Automatic type coercion does not exist.

33

37

34```

38```

project-m36.cabal+2

@@ -127,6 +127,8 @@ Library

127 ProjectM36.DataTypes.Maybe,

128 ProjectM36.DataTypes.List,

129 ProjectM36.DataTypes.Primitive,

130+ ProjectM36.DataTypes.Interval,

131+ ProjectM36.DataTypes.ByteString,

130 ProjectM36.MiscUtils,

132 ProjectM36.MiscUtils,

131 ProjectM36.Notifications,

133 ProjectM36.Notifications,

132 ProjectM36.Relation,

134 ProjectM36.Relation,

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+16−1

@@ -79,6 +79,15 @@ instance ToJSON Atom where

79 "val" .= decodeUtf8 (B64.encode i) ]

80 toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom,

81 "val" .= i ]

82+

83+ toJSON atom@(IntervalAtom b e i1 i2) = object [ "type" .= atomTypeForAtom atom,

84+ "val" .= object [

85+ "begin" .= toJSON b,

86+ "end" .= toJSON e,

87+ "beginopen" .= i1,

88+ "endopen" .= i2

89+ ]

90+ ]

82 toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom,

91 toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom,

83 "val" .= i ]

92 "val" .= i ]

84 toJSON (ConstructedAtom dConsName atomtype atomlist) = object [

93 toJSON (ConstructedAtom dConsName atomtype atomlist) = object [

@@ -91,7 +100,7 @@ instance FromJSON Atom where

91 parseJSON = withObject "atom" $ \o -> do

100 parseJSON = withObject "atom" $ \o -> do

92 atype <- o .: "type"

101 atype <- o .: "type"

93 case atype of

102 case atype of

94− TypeVariableType _ -> fail "cannot pass AnyAtomType over the wire"

103+ TypeVariableType _ -> fail "cannot pass TypeVariableType over the wire"

95 caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"

104 caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"

96 RelationAtomType _ -> do

105 RelationAtomType _ -> do

97 rel <- o .: "val"

106 rel <- o .: "val"

@@ -109,6 +118,12 @@ instance FromJSON Atom where

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

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

110 Right bs -> pure (ByteStringAtom bs)

119 Right bs -> pure (ByteStringAtom bs)

111 BoolAtomType -> BoolAtom <$> o .: "val"

120 BoolAtomType -> BoolAtom <$> o .: "val"

121+ IntervalAtomType _ -> IntervalAtom <$>

122+ ((o .: "val") >>= (.: "begin")) <*>

123+ ((o .: "val") >>= (.: "end")) <*>

124+ ((o .: "val") >>= (.: "beginopen")) <*>

125+ ((o .: "val") >>= (.: "endopen"))

126+

112

127

113instance ToJSON Notification

128instance ToJSON Notification

114instance FromJSON Notification

129instance FromJSON Notification

src/lib/ProjectM36/Atom.hs+7

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

6--import Data.Time.Clock

7--import Data.ByteString (ByteString)

8import Text.Read

9+import Data.Monoid

9

10

10relationForAtom :: Atom -> Either RelationalError Relation

11relationForAtom :: Atom -> Either RelationalError Relation

11relationForAtom (RelationAtom rel) = Right rel

12relationForAtom (RelationAtom rel) = Right rel

@@ -29,6 +30,12 @@ atomToText (DayAtom i) = (T.pack . show) i

29atomToText (DateTimeAtom i) = (T.pack . show) i

30atomToText (DateTimeAtom i) = (T.pack . show) i

30atomToText (ByteStringAtom i) = (T.pack . show) i

31atomToText (ByteStringAtom i) = (T.pack . show) i

31atomToText (BoolAtom i) = (T.pack . show) i

32atomToText (BoolAtom i) = (T.pack . show) i

33+atomToText (IntervalAtom b e bo be) = beginp <> begin <> "," <> end <> endp

34+ where beginp = if bo then "(" else "["

35+ begin = atomToText b

36+ end = atomToText e

37+ endp = if be then ")" else "]"

38+

32atomToText (RelationAtom i) = (T.pack . show) i

39atomToText (RelationAtom i) = (T.pack . show) i

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

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

34

41

src/lib/ProjectM36/AtomFunctionError.hs+5

@@ -3,9 +3,14 @@ module ProjectM36.AtomFunctionError where

3import Data.Binary

4import GHC.Generics

5import Control.DeepSeq

6+import Data.Text

6

7

7data AtomFunctionError = AtomFunctionUserError String |

8data AtomFunctionError = AtomFunctionUserError String |

8 AtomFunctionTypeMismatchError |

9 AtomFunctionTypeMismatchError |

10+ InvalidIntervalOrdering |

11+ InvalidIntervalBoundaries |

12+ AtomTypeDoesNotSupportOrdering Text |

13+ AtomTypeDoesNotSupportInterval Text |

9 AtomFunctionBytesDecodingError String

14 AtomFunctionBytesDecodingError String

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

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

11

16

src/lib/ProjectM36/AtomFunctions/Basic.hs+5−1

@@ -4,6 +4,8 @@ import ProjectM36.Base

4import ProjectM36.DataTypes.Day

5import ProjectM36.DataTypes.Either

6import ProjectM36.DataTypes.Maybe

7+import ProjectM36.DataTypes.Interval

8+import ProjectM36.DataTypes.ByteString

7import ProjectM36.AtomFunctions.Primitive

9import ProjectM36.AtomFunctions.Primitive

8import ProjectM36.AtomFunction

10import ProjectM36.AtomFunction

9import ProjectM36.DataTypes.List

11import ProjectM36.DataTypes.List

@@ -16,7 +18,9 @@ basicAtomFunctions = HS.unions [primitiveAtomFunctions,

16 dateTimeAtomFunctions,

18 dateTimeAtomFunctions,

17 eitherAtomFunctions,

19 eitherAtomFunctions,

18 maybeAtomFunctions,

20 maybeAtomFunctions,

19− listAtomFunctions]

21+ listAtomFunctions,

22+ bytestringAtomFunctions,

23+ intervalAtomFunctions]

20

24

21--these special atom functions aren't scripted so they can't be serialized normally. Instead, the body remains in the binary and the serialization/deserialization happens by name only.

25--these special atom functions aren't scripted so they can't be serialized normally. Instead, the body remains in the binary and the serialization/deserialization happens by name only.

22precompiledAtomFunctions :: AtomFunctions

26precompiledAtomFunctions :: AtomFunctions

src/lib/ProjectM36/AtomFunctions/Primitive.hs+1−8

@@ -6,8 +6,6 @@ import ProjectM36.AtomFunctionError

6import ProjectM36.AtomFunction

7import qualified Data.HashSet as HS

8import qualified Data.Vector as V

9−import qualified Data.ByteString.Base64 as B64

10−import qualified Data.Text.Encoding as TE

11import Control.Monad

9import Control.Monad

12

10

13primitiveAtomFunctions :: AtomFunctions

11primitiveAtomFunctions :: AtomFunctions

@@ -45,12 +43,7 @@ primitiveAtomFunctions = HS.fromList [

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

43 atomFuncBody = body $ intAtomFuncLessThan True >=> boolAtomNot},

46 AtomFunction { atomFuncName = "not",

44 AtomFunction { atomFuncName = "not",

47 atomFuncType = [BoolAtomType, BoolAtomType],

45 atomFuncType = [BoolAtomType, BoolAtomType],

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

46+ atomFuncBody = body $ \(b:_) -> boolAtomNot b }

49− AtomFunction { atomFuncName = "makeByteString",

50− atomFuncType = [TextAtomType, ByteStringAtomType],

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

52− Left err -> Left (AtomFunctionBytesDecodingError err)

53− Right bs -> pure (ByteStringAtom bs) }

54 ]

47 ]

55 where

48 where

56 body = AtomFunctionBody Nothing

49 body = AtomFunctionBody Nothing

src/lib/ProjectM36/AtomType.hs+4

@@ -234,6 +234,7 @@ atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do

234 else

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

236 return x

237+atomTypeVerify (IntervalAtomType typA) (IntervalAtomType typB) = atomTypeVerify typA typB

237atomTypeVerify x y = if x == y then

238atomTypeVerify x y = if x == y then

238 Right x

239 Right x

239 else

240 else

@@ -250,6 +251,7 @@ prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append`

250 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

251 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

251-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

252-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

252prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"

253prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"

254+prettyAtomType (IntervalAtomType tv) = "Interval (" <> prettyAtomType tv <> ")"

253prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

255prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

254 where fullName = (T.pack . show) aType

256 where fullName = (T.pack . show) aType

255

257

@@ -273,6 +275,7 @@ resolveTypeVariables expectedArgTypes actualArgTypes = do

273

275

274resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap

276resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap

275resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ

277resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ

278+resolveTypeVariable (IntervalAtomType ityp) typ = resolveTypeVariable ityp typ

276resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap

279resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap

277resolveTypeVariable _ _ = M.empty

280resolveTypeVariable _ _ = M.empty

278

281

@@ -283,6 +286,7 @@ resolveFunctionReturnValue funcName tvMap (ConstructedAtomType tCons retMap) = d

283 pure (ConstructedAtomType tCons (M.intersection tvMap retMap))

286 pure (ConstructedAtomType tCons (M.intersection tvMap retMap))

284 else

287 else

285 Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))

288 Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))

289+resolveFunctionReturnValue funcName tvMap (IntervalAtomType tv) = IntervalAtomType <$> resolveFunctionReturnValue funcName tvMap tv

286resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of

290resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of

287 Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)

291 Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)

288 Just typ -> pure typ

292 Just typ -> pure typ

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

@@ -102,7 +102,7 @@ instance Atomable Bool where

102 fromAtom _ = error "improper fromAtom"

103 toAtomType _ = BoolAtomType

104 toDatabaseContextExpr _ = NoOperation

105−

105+

106instance Atomable Relation where

107 toAtom = RelationAtom

108 fromAtom (RelationAtom r) = r

src/lib/ProjectM36/Base.hs+5

@@ -34,10 +34,13 @@ data Atom = IntAtom Int |

34 DateTimeAtom UTCTime |

35 ByteStringAtom ByteString |

36 BoolAtom Bool |

37+ IntervalAtom Atom Atom OpenInterval OpenInterval |

37 RelationAtom Relation |

38 RelationAtom Relation |

38 ConstructedAtom DataConstructorName AtomType [Atom]

39 ConstructedAtom DataConstructorName AtomType [Atom]

39 deriving (Eq, Show, Binary, Typeable, NFData, Generic)

40 deriving (Eq, Show, Binary, Typeable, NFData, Generic)

40

41

42+type OpenInterval = Bool

43+

41instance Hashable Atom where

44instance Hashable Atom where

42 hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

45 hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms

43 `hashWithSalt` dConsName --AtomType is not hashable

46 `hashWithSalt` dConsName --AtomType is not hashable

@@ -48,6 +51,7 @@ instance Hashable Atom where

48 hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt

51 hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt

49 hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs

52 hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs

50 hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

53 hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b

54+ hashWithSalt salt (IntervalAtom a1 a2 bo be) = salt `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` bo `hashWithSalt` be

51 hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

55 hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r

52

56

53instance Binary UTCTime where

57instance Binary UTCTime where

@@ -71,6 +75,7 @@ data AtomType = IntAtomType |

71 DateTimeAtomType |

75 DateTimeAtomType |

72 ByteStringAtomType |

76 ByteStringAtomType |

73 BoolAtomType |

77 BoolAtomType |

78+ IntervalAtomType AtomType |

74 RelationAtomType Attributes |

79 RelationAtomType Attributes |

75 ConstructedAtomType TypeConstructorName TypeVarMap |

80 ConstructedAtomType TypeConstructorName TypeVarMap |

76 TypeVariableType TypeVarName

81 TypeVariableType TypeVarName

src/lib/ProjectM36/DataTypes/ByteString.hsnew file+18

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

1+module ProjectM36.DataTypes.ByteString where

2+import ProjectM36.Base

3+import ProjectM36.AtomFunctionError

4+import ProjectM36.AtomFunctionBody

5+import qualified Data.HashSet as HS

6+import qualified Data.ByteString.Base64 as B64

7+import qualified Data.Text.Encoding as TE

8+

9+bytestringAtomFunctions :: AtomFunctions

10+bytestringAtomFunctions = HS.fromList [

11+ AtomFunction { atomFuncName = "bytestring",

12+ atomFuncType = [TextAtomType, ByteStringAtomType],

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

14+ Left err -> Left (AtomFunctionBytesDecodingError err)

15+ Right bs -> pure (ByteStringAtom bs)

16+ }

17+ ]

18+

src/lib/ProjectM36/DataTypes/Interval.hs+99−29

@@ -1,35 +1,105 @@

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

2module ProjectM36.DataTypes.Interval where

3−import Data.Interval

3+import ProjectM36.AtomFunctionBody

4−import ProjectM36.Base hiding (Finite)

4+import ProjectM36.Base

5−import Data.Binary

5+import ProjectM36.AtomType

6−import ProjectM36.Atom

6+import ProjectM36.DataTypes.Primitive

7−import Data.Typeable

7+import ProjectM36.AtomFunctionError

8−import Data.Time.Clock

8+import qualified Data.HashSet as HS

9

10−instance (Atomable a, Ord a) => Atomable (Interval a)

10+-- in lieu of typeclass support, we just hard-code the types which can be part of an interval

11+supportsInterval :: AtomType -> Bool

12+supportsInterval typ = case typ of

13+ IntAtomType -> True

14+ DoubleAtomType -> True

15+ TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval

16+ DayAtomType -> True

17+ DateTimeAtomType -> True

18+ ByteStringAtomType -> False

19+ BoolAtomType -> False

20+ IntervalAtomType _ -> False

21+ RelationAtomType _ -> False

22+ ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this

23+ TypeVariableType _ -> False

24+

25+supportsOrdering :: AtomType -> Bool

26+supportsOrdering typ = case typ of

27+ IntAtomType -> True

28+ DoubleAtomType -> True

29+ TextAtomType -> True

30+ DayAtomType -> True

31+ DateTimeAtomType -> True

32+ ByteStringAtomType -> False

33+ BoolAtomType -> False

34+ IntervalAtomType _ -> False

35+ RelationAtomType _ -> False

36+ ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this

37+ TypeVariableType _ -> False

38+

39+atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering

40+atomCompare a1 a2 = let aType = atomTypeForAtom a1

41+ go a b = Right (compare a b)

42+ typError = Left (AtomTypeDoesNotSupportOrdering (prettyAtomType aType)) in

43+ if atomTypeForAtom a1 /= atomTypeForAtom a2 then

44+ Left AtomFunctionTypeMismatchError

45+ else if not (supportsOrdering aType) then

46+ typError

47+ else

48+ case (a1, a2) of

49+ (IntAtom a, IntAtom b) -> go a b

50+ (DoubleAtom a, DoubleAtom b) -> go a b

51+ (TextAtom a, TextAtom b) -> go a b

52+ (DayAtom a, DayAtom b) -> go a b

53+ (DateTimeAtom a, DateTimeAtom b) -> go a b

54+ _ -> typError

55+

56+--check that interval is properly ordered and that the boundaries make sense

57+createInterval :: Atom -> Atom -> OpenInterval -> OpenInterval -> Either AtomFunctionError Atom

58+createInterval atom1 atom2 bopen eopen = do

59+ cmp <- atomCompare atom1 atom2

60+ case cmp of

61+ GT -> Left InvalidIntervalOrdering

62+ EQ -> if bopen || eopen then

63+ Left InvalidIntervalBoundaries

64+ else

65+ Right valid

66+ LT -> Right valid

67+ where valid = IntervalAtom atom1 atom2 bopen eopen

68+

69+intervalAtomFunctions :: AtomFunctions

70+intervalAtomFunctions = HS.fromList [

71+ AtomFunction { atomFuncName = "interval",

72+ atomFuncType = [TypeVariableType "a",

73+ TypeVariableType "a",

74+ BoolAtomType,

75+ BoolAtomType,

76+ IntervalAtomType (TypeVariableType "a")],

77+ atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do

78+ let aType = atomTypeForAtom atom1

79+ if supportsInterval aType then

80+ createInterval atom1 atom2 bopen eopen

81+ else

82+ Left (AtomTypeDoesNotSupportInterval (prettyAtomType aType))

83+ },

84+ AtomFunction {

85+ atomFuncName = "interval_overlaps",

86+ atomFuncType = [IntervalAtomType (TypeVariableType "a"),

87+ IntervalAtomType (TypeVariableType "a"),

88+ BoolAtomType],

89+ atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do

90+ res <- intervalOverlaps i1 i2

91+ pure (BoolAtom res)

92+ }]

11

93

12−instance (Binary a) => Binary (Extended a) where

13− put ext = case ext of

14− NegInf -> put (1 :: Int)

15− PosInf -> put (2 :: Int)

16− Finite x -> put (3 :: Int) >> put x

17− get = do

18− flag <- get :: Get Int

19− case flag of

20− 1 -> pure NegInf

21− 2 -> pure PosInf

22− 3 -> Finite <$> get

23− _ -> error "poop"

24

94

25−instance (Ord a, Binary a) => Binary (Interval a) where

95+intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool

26− put interv = put (lowerBound interv) >> put (upperBound interv)

96+intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAtom i2start i2end i2startopen i2endopen) = do

27− get = interval <$> get <*> get

97+ cmp1 <- atomCompare i1start i2end

98+ cmp2 <- atomCompare i2start i1end

99+ let startcmp = if i1startopen then oplt else oplte

100+ endcmp = if i2startopen then oplt else oplte

101+ oplte op = op == LT || op == EQ

102+ oplt op = op == LT

103+ pure (startcmp cmp1 && endcmp cmp2)

104+intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError

28

105

29−intervalFunctions :: [AtomFunction]

30−intervalFunctions = [AtomFunction { atomFuncName = "interval_dt_member",

31− atomFuncType = [dateTimeAtomType,

32− atomTypeForProxy (Proxy :: Proxy (Interval UTCTime)),

33− boolAtomType],

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

35− ]

src/lib/ProjectM36/DataTypes/Primitive.hs+1

@@ -33,5 +33,6 @@ atomTypeForAtom (DayAtom _) = DayAtomType

33atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType

34atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType

35atomTypeForAtom (BoolAtom _) = BoolAtomType

36+atomTypeForAtom (IntervalAtom a _ _ _) = IntervalAtomType (atomTypeForAtom a)

36atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs

37atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs

37atomTypeForAtom (ConstructedAtom _ aType _) = aType

38atomTypeForAtom (ConstructedAtom _ aType _) = aType

src/lib/ProjectM36/RelationalExpression.hs+4−1

@@ -741,7 +741,10 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

741 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments

742 case evalAtomFunction func evaldArgs of

743 Left err -> throwE (AtomFunctionUserError err)

744− Right result -> pure result

744+ Right result -> do

745+ --validate that the result matches the expected type

746+ _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))

747+ pure result

745evalAtomExpr tupIn (RelationAtomExpr relExpr) = do

748evalAtomExpr tupIn (RelationAtomExpr relExpr) = do

746 --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes

749 --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes

747 rstate <- ask

750 rstate <- ask

test/TutorialD/Interpreter.hs+17−3

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

34 tcounts <- runTestTT (TestList tests)

35 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

36 where

37− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments, testTransGraphRelationalExpr, failJoinTest, testMultiAttributeRename, testSchemaExpr, testRelationalExprStateTupleElems, testFunctionalDependencies, testEmptyCommits]

37+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments, testTransGraphRelationalExpr, failJoinTest, testMultiAttributeRename, testSchemaExpr, testRelationalExprStateTupleElems, testFunctionalDependencies, testEmptyCommits,testIntervalAtom]

38 simpleRelTests = [("x:=true", Right relationTrue),

39 ("x:=false", Right relationFalse),

40 ("x:=true union false", Right relationTrue),

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

118 ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")),

119 ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right relationTrue),

120 --test binary bytestring data type

121− ("x:=relation{tuple{y makeByteString(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),

121+ ("x:=relation{tuple{y bytestring(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),

122 --test Maybe Text

123 ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),

124 --test Maybe Int

@@ -434,4 +434,18 @@ testEmptyCommits = TestCase $ do

434 dirty''' <- disconnectedTransactionIsDirty sessionId dbconn

435 assertEqual "empty delete empty commit" (Right False) dirty'''

436

437−

437+testIntervalAtom :: Test

438+testIntervalAtom = TestCase $ do

439+ --test interval creation

440+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

441+ executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}"

442+ --test failed interval creation

443+ let err1 = "AtomFunctionUserError InvalidIntervalOrdering"

444+ err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportInterval \"Text\")"

445+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}"

446+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}"

447+

448+ --test interval_overlaps

449+ executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"

450+ eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ()))

451+ assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntAtomType]) [[BoolAtom True, IntAtom 1], [BoolAtom False, IntAtom 2]]) eRv