git.iko.soy/project-m36
on fe735ff help sign in
project-m36/src/lib/ProjectM36/DataTypes/Interval.hs
108 lines 4.8 kB history raw
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2module ProjectM36.DataTypes.Interval where
3import ProjectM36.AtomFunctionBody
4import ProjectM36.Base
5import ProjectM36.AtomType
6import ProjectM36.DataTypes.Primitive
7import ProjectM36.AtomFunctionError
8import qualified Data.HashSet as HS
10-- in lieu of typeclass support, we just hard-code the types which can be part of an interval
11supportsInterval :: AtomType -> Bool
12supportsInterval typ = case typ of
13 IntAtomType -> True
14 IntegerAtomType -> True
15 DoubleAtomType -> True
16 TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval
17 DayAtomType -> True
18 DateTimeAtomType -> True
19 ByteStringAtomType -> False
20 BoolAtomType -> False
21 IntervalAtomType _ -> False
22 RelationAtomType _ -> False
23 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this
24 TypeVariableType _ -> False
26supportsOrdering :: AtomType -> Bool
27supportsOrdering typ = case typ of
28 IntAtomType -> True
29 IntegerAtomType -> 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
41atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering
42atomCompare a1 a2 = let aType = atomTypeForAtom a1
43 go a b = Right (compare a b)
44 typError = Left (AtomTypeDoesNotSupportOrderingError (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 (IntegerAtom a, IntegerAtom b) -> go a b
52 (IntAtom a, IntAtom b) -> go a b
53 (DoubleAtom a, DoubleAtom b) -> go a b
54 (TextAtom a, TextAtom b) -> go a b
55 (DayAtom a, DayAtom b) -> go a b
56 (DateTimeAtom a, DateTimeAtom b) -> go a b
57 _ -> typError
59--check that interval is properly ordered and that the boundaries make sense
60createInterval :: Atom -> Atom -> OpenInterval -> OpenInterval -> Either AtomFunctionError Atom
61createInterval atom1 atom2 bopen eopen = do
62 cmp <- atomCompare atom1 atom2
63 case cmp of
64 GT -> Left InvalidIntervalOrderingError
65 EQ -> if bopen || eopen then
66 Left InvalidIntervalBoundariesError
67 else
68 Right valid
69 LT -> Right valid
70 where valid = IntervalAtom atom1 atom2 bopen eopen
72intervalAtomFunctions :: AtomFunctions
73intervalAtomFunctions = HS.fromList [
74 AtomFunction { atomFuncName = "interval",
75 atomFuncType = [TypeVariableType "a",
76 TypeVariableType "a",
77 BoolAtomType,
78 BoolAtomType,
79 IntervalAtomType (TypeVariableType "a")],
80 atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do
81 let aType = atomTypeForAtom atom1
82 if supportsInterval aType then
83 createInterval atom1 atom2 bopen eopen
84 else
85 Left (AtomTypeDoesNotSupportIntervalError (prettyAtomType aType))
86 },
87 AtomFunction {
88 atomFuncName = "interval_overlaps",
89 atomFuncType = [IntervalAtomType (TypeVariableType "a"),
90 IntervalAtomType (TypeVariableType "a"),
91 BoolAtomType],
92 atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do
93 res <- intervalOverlaps i1 i2
94 pure (BoolAtom res)
95 }]
98intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool
99intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAtom i2start i2end i2startopen i2endopen) = do
100 cmp1 <- atomCompare i1start i2end
101 cmp2 <- atomCompare i2start i1end
102 let startcmp = if i1startopen || i2endopen then oplt else oplte
103 endcmp = if i2startopen || i1endopen then oplt else oplte
104 oplte op = op == LT || op == EQ
105 oplt op = op == LT
106 pure (startcmp cmp1 && endcmp cmp2)
107intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError