git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/src/lib/ProjectM36/DataTypes/Interval.hs
105 lines 4.6 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 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
25supportsOrdering :: AtomType -> Bool
26supportsOrdering 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
39atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering
40atomCompare 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
56--check that interval is properly ordered and that the boundaries make sense
57createInterval :: Atom -> Atom -> OpenInterval -> OpenInterval -> Either AtomFunctionError Atom
58createInterval 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
69intervalAtomFunctions :: AtomFunctions
70intervalAtomFunctions = 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 }]
95intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool
96intervalOverlaps (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 || i2endopen then oplt else oplte
100 endcmp = if i2startopen || i1endopen then oplt else oplte
101 oplte op = op == LT || op == EQ
102 oplt op = op == LT
103 pure (startcmp cmp1 && endcmp cmp2)
104intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError