@@ -6,7 +6,25 @@ import ProjectM36.AtomType
66import ProjectM36.DataTypes.Primitive
77import ProjectM36.AtomFunctionError
88import qualified Data.HashSet as HS
9+import qualified Data.Map as M
10+import Control.Monad (when)
911
12+type OpenInterval = Bool
13+
14+intervalSubType :: AtomType -> AtomType
15+intervalSubType typ = if isIntervalAtomType typ then
16+ case typ of
17+ ConstructedAtomType _ tvMap ->
18+ case M.lookup "a" tvMap of
19+ Nothing -> err
20+ Just typ' -> typ'
21+ _ -> err
22+ else
23+ err
24+ where
25+ err = error "intervalSubType on non-interval type"
26+
27+
1028-- in lieu of typeclass support, we just hard-code the types which can be part of an interval
1129supportsInterval :: AtomType -> Bool
1230supportsInterval typ = case typ of
@@ -18,7 +36,6 @@ supportsInterval typ = case typ of
1836 DateTimeAtomType -> True
1937 ByteStringAtomType -> False
2038 BoolAtomType -> False
21− IntervalAtomType _ -> False
2239 RelationAtomType _ -> False
2340 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this
2441 TypeVariableType _ -> False
@@ -33,7 +50,6 @@ supportsOrdering typ = case typ of
3350 DateTimeAtomType -> True
3451 ByteStringAtomType -> False
3552 BoolAtomType -> False
36− IntervalAtomType _ -> False
3753 RelationAtomType _ -> False
3854 ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this
3955 TypeVariableType _ -> False
@@ -67,7 +83,11 @@ createInterval atom1 atom2 bopen eopen = do
6783 else
6884 Right valid
6985 LT -> Right valid
70− where valid = IntervalAtom atom1 atom2 bopen eopen
86+ where valid = ConstructedAtom "Interval" iType [atom1, atom2, BoolAtom bopen, BoolAtom eopen]
87+ iType = intervalAtomType (atomTypeForAtom atom1)
88+
89+intervalAtomType :: AtomType -> AtomType
90+intervalAtomType typ = ConstructedAtomType "Interval" (M.singleton "a" typ)
7191
7292intervalAtomFunctions :: AtomFunctions
7393intervalAtomFunctions = HS.fromList [
@@ -76,7 +96,7 @@ intervalAtomFunctions = HS.fromList [
7696 TypeVariableType "a",
7797 BoolAtomType,
7898 BoolAtomType,
79− IntervalAtomType (TypeVariableType "a")],
99+ intervalAtomType (TypeVariableType "a")],
80100 atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do
81101 let aType = atomTypeForAtom atom1
82102 if supportsInterval aType then
@@ -86,31 +106,33 @@ intervalAtomFunctions = HS.fromList [
86106 },
87107 AtomFunction {
88108 atomFuncName = "interval_overlaps",
89− atomFuncType = [IntervalAtomType (TypeVariableType "a"),
90− IntervalAtomType (TypeVariableType "a"),
109+ atomFuncType = [intervalAtomType (TypeVariableType "a"),
110+ intervalAtomType (TypeVariableType "a"),
91111 BoolAtomType],
92− atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) ->
112+ atomFuncBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) ->
93113 BoolAtom <$> intervalOverlaps i1 i2
94114 }]
95−
96−
115+
116+isIntervalAtomType :: AtomType -> Bool
117+isIntervalAtomType (ConstructedAtomType nam tvMap) =
118+ nam == "Interval" && M.keys tvMap == ["a"] && case M.lookup "a" tvMap of
119+ Nothing -> False
120+ Just subType -> supportsInterval subType || subType == TypeVariableType "a"
121+isIntervalAtomType _ = False
122+
97123intervalOverlaps :: 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 || i2endopen then oplt else oplte
102− endcmp = if i2startopen || i1endopen then oplt else oplte
103− oplte op = op == LT || op == EQ
104− oplt op = op == LT
105− pure (startcmp cmp1 && endcmp cmp2)
124+intervalOverlaps (ConstructedAtom dCons1 typ1 (i1start:i1end:(BoolAtom i1startopen):(BoolAtom i1endopen):[])) (ConstructedAtom dCons2 typ2 (i2start:i2end:(BoolAtom i2startopen):(BoolAtom i2endopen):[])) = do
125+ when (dCons1 /= "Interval" || dCons2 /= "Interval" || not (isIntervalAtomType typ1) || not (isIntervalAtomType typ2)) (Left AtomFunctionTypeMismatchError)
126+ cmp1 <- atomCompare i1start i2end
127+ cmp2 <- atomCompare i2start i1end
128+ let startcmp = if i1startopen || i2endopen then oplt else oplte
129+ endcmp = if i2startopen || i1endopen then oplt else oplte
130+ oplte op = op == LT || op == EQ
131+ oplt op = op == LT
132+ pure (startcmp cmp1 && endcmp cmp2)
106133intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError
107134
108135intervalTypeConstructorMapping :: TypeConstructorMapping
109−--intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])]
110−intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"],
111− [DataConstructorDef "Interval" [DataConstructorDefTypeVarNameArg "a",
112− DataConstructorDefTypeVarNameArg "a",
113− ]])
114− ]
136+intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])]
115137
116138