git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/DataTypes/Interval.hs
144 lines 6.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
9import qualified Data.Map as M
10import Control.Monad (when)
11import Data.Maybe
13type OpenInterval = Bool
15intervalSubType :: AtomType -> AtomType
16intervalSubType typ = if isIntervalAtomType typ then
17 case typ of
18 ConstructedAtomType _ tvMap ->
19 fromMaybe err (M.lookup "a" tvMap)
20 _ -> err
21 else
22 err
23 where
24 err = error "intervalSubType on non-interval type"
27-- in lieu of typeclass support, we just hard-code the types which can be part of an interval
28supportsInterval :: AtomType -> Bool
29supportsInterval typ = case typ of
30 IntAtomType -> True
31 IntegerAtomType -> True
32 DoubleAtomType -> True
33 TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval
34 DayAtomType -> True
35 DateTimeAtomType -> True
36 ByteStringAtomType -> False
37 BoolAtomType -> False
38 RelationAtomType _ -> False
39 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this
40 TypeVariableType _ -> False
42supportsOrdering :: AtomType -> Bool
43supportsOrdering typ = case typ of
44 IntAtomType -> True
45 IntegerAtomType -> True
46 DoubleAtomType -> True
47 TextAtomType -> True
48 DayAtomType -> True
49 DateTimeAtomType -> True
50 ByteStringAtomType -> False
51 BoolAtomType -> False
52 RelationAtomType _ -> False
53 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this
54 TypeVariableType _ -> False
56atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering
57atomCompare a1 a2 = let aType = atomTypeForAtom a1
58 go a b = Right (compare a b)
59 typError = Left (AtomTypeDoesNotSupportOrderingError (prettyAtomType aType)) in
60 if atomTypeForAtom a1 /= atomTypeForAtom a2 then
61 Left AtomFunctionTypeMismatchError
62 else if not (supportsOrdering aType) then
63 typError
64 else
65 case (a1, a2) of
66 (IntegerAtom a, IntegerAtom b) -> go a b
67 (IntAtom a, IntAtom b) -> go a b
68 (DoubleAtom a, DoubleAtom b) -> go a b
69 (TextAtom a, TextAtom b) -> go a b
70 (DayAtom a, DayAtom b) -> go a b
71 (DateTimeAtom a, DateTimeAtom b) -> go a b
72 _ -> typError
74--check that interval is properly ordered and that the boundaries make sense
75createInterval :: Atom -> Atom -> OpenInterval -> OpenInterval -> Either AtomFunctionError Atom
76createInterval atom1 atom2 bopen eopen = do
77 cmp <- atomCompare atom1 atom2
78 case cmp of
79 GT -> Left InvalidIntervalOrderingError
80 EQ -> if bopen || eopen then
81 Left InvalidIntervalBoundariesError
82 else
83 Right valid
84 LT -> Right valid
85 where valid = ConstructedAtom "Interval" iType [atom1, atom2, BoolAtom bopen, BoolAtom eopen]
86 iType = intervalAtomType (atomTypeForAtom atom1)
88intervalAtomType :: AtomType -> AtomType
89intervalAtomType typ = ConstructedAtomType "Interval" (M.singleton "a" typ)
91intervalAtomFunctions :: AtomFunctions
92intervalAtomFunctions = HS.fromList [
93 AtomFunction { atomFuncName = "interval",
94 atomFuncType = [TypeVariableType "a",
95 TypeVariableType "a",
96 BoolAtomType,
97 BoolAtomType,
98 intervalAtomType (TypeVariableType "a")],
99 atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do
100 let aType = atomTypeForAtom atom1
101 if supportsInterval aType then
102 createInterval atom1 atom2 bopen eopen
103 else
104 Left (AtomTypeDoesNotSupportIntervalError (prettyAtomType aType))
105 },
106 AtomFunction {
107 atomFuncName = "interval_overlaps",
108 atomFuncType = [intervalAtomType (TypeVariableType "a"),
109 intervalAtomType (TypeVariableType "a"),
110 BoolAtomType],
111 atomFuncBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) ->
112 BoolAtom <$> intervalOverlaps i1 i2
113 }]
115isIntervalAtomType :: AtomType -> Bool
116isIntervalAtomType (ConstructedAtomType nam tvMap) =
117 nam == "Interval" && M.keys tvMap == ["a"] && case M.lookup "a" tvMap of
118 Nothing -> False
119 Just subType -> supportsInterval subType || subType == TypeVariableType "a"
120isIntervalAtomType _ = False
122intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool
123intervalOverlaps (ConstructedAtom dCons1 typ1 [i1start,
124 i1end,
125 BoolAtom i1startopen,
126 BoolAtom i1endopen]) (ConstructedAtom dCons2 typ2
127 [i2start,
128 i2end,
129 BoolAtom i2startopen,
130 BoolAtom i2endopen]) = do
131 when (dCons1 /= "Interval" || dCons2 /= "Interval" || not (isIntervalAtomType typ1) || not (isIntervalAtomType typ2)) (Left AtomFunctionTypeMismatchError)
132 cmp1 <- atomCompare i1start i2end
133 cmp2 <- atomCompare i2start i1end
134 let startcmp = if i1startopen || i2endopen then oplt else oplte
135 endcmp = if i2startopen || i1endopen then oplt else oplte
136 oplte op = op == LT || op == EQ
137 oplt op = op == LT
138 pure (startcmp cmp1 && endcmp cmp2)
139intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError
141intervalTypeConstructorMapping :: TypeConstructorMapping
142intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])]