@@ -1,35 +1,105 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
22module ProjectM36.DataTypes.Interval where
3−import Data.Interval
4−import ProjectM36.Base hiding (Finite)
5−import Data.Binary
6−import ProjectM36.Atom
7−import Data.Typeable
8−import Data.Time.Clock
3+import ProjectM36.AtomFunctionBody
4+import ProjectM36.Base
5+import ProjectM36.AtomType
6+import ProjectM36.DataTypes.Primitive
7+import ProjectM36.AtomFunctionError
8+import qualified Data.HashSet as HS
99
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+ }]
1193
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"
2494
25−instance (Ord a, Binary a) => Binary (Interval a) where
26− put interv = put (lowerBound interv) >> put (upperBound interv)
27− get = interval <$> get <*> get
95+intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool
96+intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAtom i2start i2end i2startopen i2endopen) = do
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
28105
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− ]