@@ -1,35 +1,107 @@
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+import Debug.Trace
11+
12+-- in lieu of typeclass support, we just hard-code the types which can be part of an interval
13+supportsInterval :: AtomType -> Bool
14+supportsInterval typ = case typ of
15+ IntAtomType -> True
16+ DoubleAtomType -> True
17+ TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval
18+ DayAtomType -> True
19+ DateTimeAtomType -> True
20+ ByteStringAtomType -> False
21+ BoolAtomType -> False
22+ IntervalAtomType _ -> False
23+ RelationAtomType _ -> False
24+ ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this
25+ TypeVariableType _ -> False
26+
27+supportsOrdering :: AtomType -> Bool
28+supportsOrdering typ = case typ of
29+ IntAtomType -> True
30+ DoubleAtomType -> True
31+ TextAtomType -> True
32+ DayAtomType -> True
33+ DateTimeAtomType -> True
34+ ByteStringAtomType -> False
35+ BoolAtomType -> False
36+ IntervalAtomType _ -> False
37+ RelationAtomType _ -> False
38+ ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this
39+ TypeVariableType _ -> False
40+
41+atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering
42+atomCompare a1 a2 = let aType = atomTypeForAtom a1
43+ go a b = Right (compare a b)
44+ typError = Left (AtomTypeDoesNotSupportOrdering (prettyAtomType aType)) in
45+ if atomTypeForAtom a1 /= atomTypeForAtom a2 then
46+ Left AtomFunctionTypeMismatchError
47+ else if not (supportsOrdering aType) then
48+ typError
49+ else
50+ case (a1, a2) of
51+ (IntAtom a, IntAtom b) -> go a b
52+ (DoubleAtom a, DoubleAtom b) -> go a b
53+ (TextAtom a, TextAtom b) -> go a b
54+ (DayAtom a, DayAtom b) -> go a b
55+ (DateTimeAtom a, DateTimeAtom b) -> go a b
56+ _ -> typError
57+
58+--check that interval is properly ordered and that the boundaries make sense
59+createInterval :: Atom -> Atom -> OpenInterval -> OpenInterval -> Either AtomFunctionError Atom
60+createInterval atom1 atom2 bopen eopen = do
61+ cmp <- atomCompare atom1 atom2
62+ case cmp of
63+ GT -> Left InvalidIntervalOrdering
64+ EQ -> if bopen || eopen then
65+ Left InvalidIntervalBoundaries
66+ else
67+ Right valid
68+ LT -> Right valid
69+ where valid = IntervalAtom atom1 atom2 bopen eopen
70+
71+intervalAtomFunctions :: AtomFunctions
72+intervalAtomFunctions = HS.fromList [
73+ AtomFunction { atomFuncName = "interval",
74+ atomFuncType = [TypeVariableType "a",
75+ TypeVariableType "a",
76+ BoolAtomType,
77+ BoolAtomType,
78+ IntervalAtomType (TypeVariableType "a")],
79+ atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do
80+ let aType = atomTypeForAtom atom1
81+ if supportsInterval aType then
82+ createInterval atom1 atom2 bopen eopen
83+ else
84+ Left (AtomTypeDoesNotSupportInterval (prettyAtomType aType))
85+ },
86+ AtomFunction {
87+ atomFuncName = "interval_overlaps",
88+ atomFuncType = [IntervalAtomType (TypeVariableType "a"),
89+ IntervalAtomType (TypeVariableType "a"),
90+ BoolAtomType],
91+ atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do
92+ res <- intervalOverlaps i1 i2
93+ pure (BoolAtom res)
94+ }]
1195
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"
2496
25−instance (Ord a, Binary a) => Binary (Interval a) where
26− put interv = put (lowerBound interv) >> put (upperBound interv)
27− get = interval <$> get <*> get
97+intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool
98+intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAtom i2start i2end i2startopen i2endopen) = do
99+ cmp1 <- atomCompare i1start i2end
100+ cmp2 <- atomCompare i2start i1end
101+ let startcmp = if i1startopen then oplt else oplte
102+ endcmp = if i2startopen then oplt else oplte
103+ oplte op = op == LT || op == EQ
104+ oplt op = op == LT
105+ pure (startcmp cmp1 && endcmp cmp2)
106+intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError
28107
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− ]