{-# OPTIONS_GHC -fno-warn-orphans #-}
module ProjectM36.DataTypes.Interval where
import ProjectM36.AtomFunctionBody
import ProjectM36.Base
import ProjectM36.AtomType
import ProjectM36.DataTypes.Primitive
import ProjectM36.AtomFunctionError
import qualified Data.HashSet as HS
import qualified Data.Map as M
import Control.Monad (when)
import Data.Maybe

type OpenInterval = Bool                     

intervalSubType :: AtomType -> AtomType
intervalSubType :: AtomType -> AtomType
intervalSubType AtomType
typ = if AtomType -> Bool
isIntervalAtomType AtomType
typ then
                        case AtomType
typ of
                          ConstructedAtomType TypeConstructorName
_ TypeVarMap
tvMap -> 
                            forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TypeConstructorName
"a" TypeVarMap
tvMap)
                          AtomType
_ -> forall {a}. a
err
                        else
                        forall {a}. a
err
  where
   err :: a
err = forall a. HasCallStack => [Char] -> a
error [Char]
"intervalSubType on non-interval type"
  
                 
-- in lieu of typeclass support, we just hard-code the types which can be part of an interval
supportsInterval :: AtomType -> Bool
supportsInterval :: AtomType -> Bool
supportsInterval AtomType
typ = case AtomType
typ of
  AtomType
IntAtomType -> Bool
True
  AtomType
IntegerAtomType -> Bool
True
  AtomType
ScientificAtomType -> Bool
True
  AtomType
DoubleAtomType -> Bool
True
  AtomType
TextAtomType -> Bool
False -- just because it supports ordering, doesn't mean it makes sense in an interval
  AtomType
DayAtomType -> Bool
True               
  AtomType
DateTimeAtomType -> Bool
True
  AtomType
ByteStringAtomType -> Bool
False
  AtomType
BoolAtomType -> Bool
False
  AtomType
UUIDAtomType -> Bool
False
  RelationAtomType Attributes
_ -> Bool
False
  ConstructedAtomType TypeConstructorName
_ TypeVarMap
_ -> Bool
False --once we support an interval-style typeclass, we might enable this
  AtomType
RelationalExprAtomType -> Bool
False
  SubrelationFoldAtomType{} -> Bool
False
  TypeVariableType TypeConstructorName
_ -> Bool
False
  
supportsOrdering :: AtomType -> Bool  
supportsOrdering :: AtomType -> Bool
supportsOrdering AtomType
typ = case AtomType
typ of
  AtomType
IntAtomType -> Bool
True
  AtomType
IntegerAtomType -> Bool
True
  AtomType
ScientificAtomType -> Bool
True
  AtomType
DoubleAtomType -> Bool
True
  AtomType
TextAtomType -> Bool
True
  AtomType
DayAtomType -> Bool
True               
  AtomType
DateTimeAtomType -> Bool
True
  AtomType
ByteStringAtomType -> Bool
False
  AtomType
BoolAtomType -> Bool
False
  AtomType
UUIDAtomType -> Bool
False
  RelationAtomType Attributes
_ -> Bool
False
  AtomType
RelationalExprAtomType -> Bool
False
  SubrelationFoldAtomType{} -> Bool
False
  ConstructedAtomType TypeConstructorName
_ TypeVarMap
_ -> Bool
False --once we support an interval-style typeclass, we might enable this
  TypeVariableType TypeConstructorName
_ -> Bool
False
  
atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering
atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering
atomCompare Atom
a1 Atom
a2 = let aType :: AtomType
aType = Atom -> AtomType
atomTypeForAtom Atom
a1 
                        go :: a -> a -> Either a Ordering
go a
a a
b = forall a b. b -> Either a b
Right (forall a. Ord a => a -> a -> Ordering
compare a
a a
b)
                        typError :: Either AtomFunctionError b
typError = forall a b. a -> Either a b
Left (TypeConstructorName -> AtomFunctionError
AtomTypeDoesNotSupportOrderingError (AtomType -> TypeConstructorName
prettyAtomType AtomType
aType)) in
                    if Atom -> AtomType
atomTypeForAtom Atom
a1 forall a. Eq a => a -> a -> Bool
/= Atom -> AtomType
atomTypeForAtom Atom
a2 then
                      forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
                    else if Bool -> Bool
not (AtomType -> Bool
supportsOrdering AtomType
aType) then
                           forall {b}. Either AtomFunctionError b
typError
                         else
                           case (Atom
a1, Atom
a2) of
                             (IntegerAtom Integer
a, IntegerAtom Integer
b) -> forall {a} {a}. Ord a => a -> a -> Either a Ordering
go Integer
a Integer
b
                             (IntAtom Int
a, IntAtom Int
b) -> forall {a} {a}. Ord a => a -> a -> Either a Ordering
go Int
a Int
b
                             (DoubleAtom Double
a, DoubleAtom Double
b) -> forall {a} {a}. Ord a => a -> a -> Either a Ordering
go Double
a Double
b
                             (TextAtom TypeConstructorName
a, TextAtom TypeConstructorName
b) -> forall {a} {a}. Ord a => a -> a -> Either a Ordering
go TypeConstructorName
a TypeConstructorName
b
                             (DayAtom Day
a, DayAtom Day
b) -> forall {a} {a}. Ord a => a -> a -> Either a Ordering
go Day
a Day
b
                             (DateTimeAtom UTCTime
a, DateTimeAtom UTCTime
b) -> forall {a} {a}. Ord a => a -> a -> Either a Ordering
go UTCTime
a UTCTime
b
                             (Atom, Atom)
_ -> forall {b}. Either AtomFunctionError b
typError

--check that interval is properly ordered and that the boundaries make sense
createInterval :: Atom -> Atom -> OpenInterval -> OpenInterval -> Either AtomFunctionError Atom
createInterval :: Atom -> Atom -> Bool -> Bool -> Either AtomFunctionError Atom
createInterval Atom
atom1 Atom
atom2 Bool
bopen Bool
eopen = do
  Ordering
cmp <- Atom -> Atom -> Either AtomFunctionError Ordering
atomCompare Atom
atom1 Atom
atom2
  case Ordering
cmp of
    Ordering
GT -> forall a b. a -> Either a b
Left AtomFunctionError
InvalidIntervalOrderingError
    Ordering
EQ -> if Bool
bopen Bool -> Bool -> Bool
|| Bool
eopen then
            forall a b. a -> Either a b
Left AtomFunctionError
InvalidIntervalBoundariesError
          else 
            forall a b. b -> Either a b
Right Atom
valid
    Ordering
LT -> forall a b. b -> Either a b
Right Atom
valid
 where valid :: Atom
valid = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"Interval" AtomType
iType [Atom
atom1, Atom
atom2, Bool -> Atom
BoolAtom Bool
bopen, Bool -> Atom
BoolAtom Bool
eopen]
       iType :: AtomType
iType = AtomType -> AtomType
intervalAtomType (Atom -> AtomType
atomTypeForAtom Atom
atom1)
       
intervalAtomType :: AtomType -> AtomType       
intervalAtomType :: AtomType -> AtomType
intervalAtomType AtomType
typ = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"Interval" (forall k a. k -> a -> Map k a
M.singleton TypeConstructorName
"a" AtomType
typ)

intervalAtomFunctions :: AtomFunctions
intervalAtomFunctions :: AtomFunctions
intervalAtomFunctions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
  Function { funcName :: TypeConstructorName
funcName = TypeConstructorName
"interval",
             funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a",
                          TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a",
                          AtomType
BoolAtomType,
                          AtomType
BoolAtomType,
                          AtomType -> AtomType
intervalAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a")],
             funcBody :: FunctionBody AtomFunctionBodyType
funcBody = AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
compiledAtomFunctionBody forall a b. (a -> b) -> a -> b
$
             \case
               (Atom
atom1:Atom
atom2:BoolAtom Bool
bopen:BoolAtom Bool
eopen:[Atom]
_) -> do
                   let aType :: AtomType
aType = Atom -> AtomType
atomTypeForAtom Atom
atom1 
                   if AtomType -> Bool
supportsInterval AtomType
aType then
                     Atom -> Atom -> Bool -> Bool -> Either AtomFunctionError Atom
createInterval Atom
atom1 Atom
atom2 Bool
bopen Bool
eopen
                     else
                     forall a b. a -> Either a b
Left (TypeConstructorName -> AtomFunctionError
AtomTypeDoesNotSupportIntervalError (AtomType -> TypeConstructorName
prettyAtomType AtomType
aType))
               [Atom]
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
               },
  Function {
    funcName :: TypeConstructorName
funcName = TypeConstructorName
"interval_overlaps",
    funcType :: [AtomType]
funcType = [AtomType -> AtomType
intervalAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a"),
                    AtomType -> AtomType
intervalAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a"),
                    AtomType
BoolAtomType],
    funcBody :: FunctionBody AtomFunctionBodyType
funcBody = AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
compiledAtomFunctionBody forall a b. (a -> b) -> a -> b
$
      \case
        i1 :: Atom
i1@ConstructedAtom{}:i2 :: Atom
i2@ConstructedAtom{}:[Atom]
_ -> 
          Bool -> Atom
BoolAtom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> Atom -> Either AtomFunctionError Bool
intervalOverlaps Atom
i1 Atom
i2
        [Atom]
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
    }]
                        
isIntervalAtomType :: AtomType -> Bool
isIntervalAtomType :: AtomType -> Bool
isIntervalAtomType (ConstructedAtomType TypeConstructorName
nam TypeVarMap
tvMap) = 
  TypeConstructorName
nam forall a. Eq a => a -> a -> Bool
== TypeConstructorName
"Interval" Bool -> Bool -> Bool
&& forall k a. Map k a -> [k]
M.keys TypeVarMap
tvMap forall a. Eq a => a -> a -> Bool
== [TypeConstructorName
"a"] Bool -> Bool -> Bool
&& case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TypeConstructorName
"a" TypeVarMap
tvMap of
    Maybe AtomType
Nothing -> Bool
False
    Just AtomType
subType -> AtomType -> Bool
supportsInterval AtomType
subType Bool -> Bool -> Bool
|| AtomType
subType forall a. Eq a => a -> a -> Bool
== TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a"
isIntervalAtomType AtomType
_ = Bool
False
    
intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool
intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool
intervalOverlaps (ConstructedAtom TypeConstructorName
dCons1 AtomType
typ1 [Atom
i1start,
                                               Atom
i1end,
                                               BoolAtom Bool
i1startopen,
                                               BoolAtom Bool
i1endopen]) (ConstructedAtom TypeConstructorName
dCons2 AtomType
typ2 
                                                                     [Atom
i2start, 
                                                                      Atom
i2end, 
                                                                      BoolAtom Bool
i2startopen,
                                                                      BoolAtom Bool
i2endopen]) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TypeConstructorName
dCons1 forall a. Eq a => a -> a -> Bool
/= TypeConstructorName
"Interval" Bool -> Bool -> Bool
|| TypeConstructorName
dCons2 forall a. Eq a => a -> a -> Bool
/= TypeConstructorName
"Interval" Bool -> Bool -> Bool
|| Bool -> Bool
not (AtomType -> Bool
isIntervalAtomType AtomType
typ1) Bool -> Bool -> Bool
|| Bool -> Bool
not (AtomType -> Bool
isIntervalAtomType AtomType
typ2)) (forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError)
  Ordering
cmp1 <- Atom -> Atom -> Either AtomFunctionError Ordering
atomCompare Atom
i1start Atom
i2end
  Ordering
cmp2 <- Atom -> Atom -> Either AtomFunctionError Ordering
atomCompare Atom
i2start Atom
i1end
  let startcmp :: Ordering -> Bool
startcmp = if Bool
i1startopen Bool -> Bool -> Bool
|| Bool
i2endopen then Ordering -> Bool
oplt else Ordering -> Bool
oplte
      endcmp :: Ordering -> Bool
endcmp = if Bool
i2startopen Bool -> Bool -> Bool
|| Bool
i1endopen then Ordering -> Bool
oplt else Ordering -> Bool
oplte
      oplte :: Ordering -> Bool
oplte Ordering
op = Ordering
op forall a. Eq a => a -> a -> Bool
== Ordering
LT Bool -> Bool -> Bool
|| Ordering
op forall a. Eq a => a -> a -> Bool
== Ordering
EQ
      oplt :: Ordering -> Bool
oplt Ordering
op = Ordering
op forall a. Eq a => a -> a -> Bool
== Ordering
LT
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ordering -> Bool
startcmp Ordering
cmp1 Bool -> Bool -> Bool
&& Ordering -> Bool
endcmp Ordering
cmp2)
intervalOverlaps Atom
_ Atom
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError      
  
intervalTypeConstructorMapping :: TypeConstructorMapping
intervalTypeConstructorMapping :: TypeConstructorMapping
intervalTypeConstructorMapping = [(TypeConstructorName -> [TypeConstructorName] -> TypeConstructorDef
ADTypeConstructorDef TypeConstructorName
"Interval" [TypeConstructorName
"a"], [])]