module ProjectM36.DataTypes.SQL.Null where
import ProjectM36.Base
import ProjectM36.AtomFunctionError
import qualified Data.Map as M
import qualified Data.HashSet as HS
import ProjectM36.DataTypes.Primitive
import ProjectM36.AtomFunction
import ProjectM36.Tuple
import ProjectM36.Relation
import Data.Maybe (isJust)
import Data.Text (Text)

-- analogous but not equivalent to a Maybe type due to how NULLs interact with every other value

nullAtomType :: AtomType -> AtomType
nullAtomType :: AtomType -> AtomType
nullAtomType AtomType
arg = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"SQLNullable" (forall k a. k -> a -> Map k a
M.singleton TypeConstructorName
"a" AtomType
arg)

nullTypeConstructorMapping :: TypeConstructorMapping
nullTypeConstructorMapping :: TypeConstructorMapping
nullTypeConstructorMapping = [(TypeConstructorName -> [TypeConstructorName] -> TypeConstructorDef
ADTypeConstructorDef TypeConstructorName
"SQLNullable" [TypeConstructorName
"a"],
                                [TypeConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef TypeConstructorName
"SQLNull" [],
                                 TypeConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef TypeConstructorName
"SQLJust" [TypeConstructorName -> DataConstructorDefArg
DataConstructorDefTypeVarNameArg TypeConstructorName
"a"]]),
                               -- used in SQL conversion from in expressions such as INSERT INTO s(city) VALUES (NULL) where the query expression must defer type resolution to SQLNull.
                               (TypeConstructorName -> [TypeConstructorName] -> TypeConstructorDef
ADTypeConstructorDef TypeConstructorName
"SQLNullOfUnknownType" [],
                                [TypeConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef TypeConstructorName
"SQLNullOfUnknownType" []])
                              ]

nullAtomFunctions :: AtomFunctions
nullAtomFunctions :: AtomFunctions
nullAtomFunctions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_equals",
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a",
                  TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"b", -- either type could be SQLNullable or a NakedAtom
                  AtomType -> AtomType
nullAtomType AtomType
BoolAtomType],
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
sqlEquals
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_and",
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a", TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"b", AtomType -> AtomType
nullAtomType AtomType
BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
nullAnd
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_or",
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a", TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"b", AtomType -> AtomType
nullAtomType AtomType
BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
nullOr
             },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_coalesce_bool", -- used in where clause so that NULLs are filtered out
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a",
                  AtomType
BoolAtomType],
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
coalesceBool
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_add",
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a", 
                  TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"b",
                  AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType],
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody (AtomType -> (Integer -> Integer -> Atom) -> AtomFunctionBodyType
sqlIntegerBinaryFunction AtomType
IntegerAtomType (\Integer
a Integer
b -> Integer -> Atom
IntegerAtom (Integer
a forall a. Num a => a -> a -> a
+ Integer
b)))
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_abs",
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a",
                  AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType],
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
sqlAbs
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_negate",
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a",
                  AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType],
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody (AtomType -> (Integer -> Atom) -> AtomFunctionBodyType
sqlIntegerUnaryFunction AtomType
IntegerAtomType (\Integer
a -> Integer -> Atom
IntegerAtom (- Integer
a)))
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_max",
      funcType :: [AtomType]
funcType = AtomType -> AtomType -> [AtomType]
foldAtomFuncType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a") (AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType),
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
sqlMax
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_min",
      funcType :: [AtomType]
funcType = AtomType -> AtomType -> [AtomType]
foldAtomFuncType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a") (AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType),
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
sqlMin
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_count",
      funcType :: [AtomType]
funcType = AtomType -> AtomType -> [AtomType]
foldAtomFuncType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a") AtomType
IntegerAtomType,
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
sqlCount
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_sum",
      funcType :: [AtomType]
funcType = AtomType -> AtomType -> [AtomType]
foldAtomFuncType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a") (AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType),
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
sqlSum
      },
    Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
"sql_isnull",
      funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a", AtomType
BoolAtomType],
      funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
sqlIsNull
      }
    ] forall a. Semigroup a => a -> a -> a
<> AtomFunctions
sqlCompareFunctions


sqlCompareFunctions :: HS.HashSet AtomFunction
sqlCompareFunctions :: AtomFunctions
sqlCompareFunctions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (TypeConstructorName, Integer -> Integer -> Bool,
 TypeConstructorName -> TypeConstructorName -> Bool)
-> AtomFunction
mkFunc [(TypeConstructorName, Integer -> Integer -> Bool,
  TypeConstructorName -> TypeConstructorName -> Bool)]
ops
  where
    mkFunc :: (TypeConstructorName, Integer -> Integer -> Bool,
 TypeConstructorName -> TypeConstructorName -> Bool)
-> AtomFunction
mkFunc (TypeConstructorName
sql_func, Integer -> Integer -> Bool
opi, TypeConstructorName -> TypeConstructorName -> Bool
opt) =
      Function {
      funcName :: TypeConstructorName
funcName = TypeConstructorName
sql_func,
        funcType :: [AtomType]
funcType = [TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a", TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"b", AtomType -> AtomType
nullAtomType AtomType
BoolAtomType],
        funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody ((Integer -> Integer -> Bool,
 TypeConstructorName -> TypeConstructorName -> Bool)
-> AtomFunctionBodyType
sqlCompareFunc (Integer -> Integer -> Bool
opi, TypeConstructorName -> TypeConstructorName -> Bool
opt))
      }
    boolNull :: Atom
boolNull = AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType forall a. Maybe a
Nothing
    sqlCompareFunc :: (Integer -> Integer -> Bool, Text -> Text -> Bool) -> [Atom] -> Either AtomFunctionError Atom
    sqlCompareFunc :: (Integer -> Integer -> Bool,
 TypeConstructorName -> TypeConstructorName -> Bool)
-> AtomFunctionBodyType
sqlCompareFunc (Integer -> Integer -> Bool
opi, TypeConstructorName -> TypeConstructorName -> Bool
opt) [Atom
atomA, Atom
atomB] = 
      case (Atom -> Maybe Atom
maybeFromAtom Atom
atomA, Atom -> Maybe Atom
maybeFromAtom Atom
atomB) of
        (Maybe Atom
Nothing, Maybe Atom
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
boolNull
        (Maybe Atom
_, Maybe Atom
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
boolNull
        (Just (IntegerAtom Integer
a), Just (IntegerAtom Integer
b)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType (forall a. a -> Maybe a
Just (Bool -> Atom
BoolAtom (Integer -> Integer -> Bool
opi Integer
a Integer
b)))
        (Just (TextAtom TypeConstructorName
a), Just (TextAtom TypeConstructorName
b)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType (forall a. a -> Maybe a
Just (Bool -> Atom
BoolAtom (TypeConstructorName -> TypeConstructorName -> Bool
opt TypeConstructorName
a TypeConstructorName
b))))
        (Maybe Atom, Maybe Atom)
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
    sqlCompareFunc (Integer -> Integer -> Bool,
 TypeConstructorName -> TypeConstructorName -> Bool)
_ [Atom]
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
    ops :: [(FunctionName,
              Integer -> Integer -> Bool,
              Text -> Text -> Bool)]
    ops :: [(TypeConstructorName, Integer -> Integer -> Bool,
  TypeConstructorName -> TypeConstructorName -> Bool)]
ops = [(TypeConstructorName
"sql_gt", forall a. Ord a => a -> a -> Bool
(>), forall a. Ord a => a -> a -> Bool
(>)),
            (TypeConstructorName
"sql_lt", forall a. Ord a => a -> a -> Bool
(<), forall a. Ord a => a -> a -> Bool
(<)),
            (TypeConstructorName
"sql_gte", forall a. Ord a => a -> a -> Bool
(>=), forall a. Ord a => a -> a -> Bool
(>=)),
            (TypeConstructorName
"sql_lte", forall a. Ord a => a -> a -> Bool
(<=), forall a. Ord a => a -> a -> Bool
(<=))
           ]

maybeFromAtom :: Atom -> Maybe Atom
maybeFromAtom :: Atom -> Maybe Atom
maybeFromAtom Atom
atom | Atom -> Bool
isNull Atom
atom = forall a. Maybe a
Nothing
maybeFromAtom Atom
atom = forall a. a -> Maybe a
Just Atom
atom           

coalesceBool :: [Atom] -> Either AtomFunctionError Atom
coalesceBool :: AtomFunctionBodyType
coalesceBool [Atom
arg] = case Atom -> Maybe Bool
sqlBool Atom
arg of
                       Maybe Bool
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Atom
BoolAtom Bool
False)
                       Just Bool
tf -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Atom
BoolAtom Bool
tf)
coalesceBool [Atom]
_other = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError                       

isSQLBool :: Atom -> Bool
isSQLBool :: Atom -> Bool
isSQLBool Atom
atom = case Atom -> AtomType
atomTypeForAtom Atom
atom of
                   ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
_ -> Bool
True
                   ConstructedAtomType TypeConstructorName
"SQLNullOfUnknownType" TypeVarMap
_ -> Bool
True
                   AtomType
BoolAtomType -> Bool
True
                   AtomType
_ -> Bool
False

sqlBool :: Atom -> Maybe Bool
sqlBool :: Atom -> Maybe Bool
sqlBool (ConstructedAtom TypeConstructorName
dConsName AtomType
aType [BoolAtom Bool
tf]) |
  TypeConstructorName
dConsName forall a. Eq a => a -> a -> Bool
== TypeConstructorName
"SQLJust" Bool -> Bool -> Bool
&&
  (AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType AtomType
BoolAtomType Bool -> Bool -> Bool
||
   AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a")) = forall a. a -> Maybe a
Just Bool
tf
sqlBool (ConstructedAtom TypeConstructorName
dConsName AtomType
aType []) |
  TypeConstructorName
dConsName forall a. Eq a => a -> a -> Bool
== TypeConstructorName
"SQLNull" Bool -> Bool -> Bool
&&
  (AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType AtomType
BoolAtomType Bool -> Bool -> Bool
||
   AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a")) = forall a. Maybe a
Nothing
sqlBool (ConstructedAtom TypeConstructorName
"SQLNullOfUnknownType" AtomType
_ []) = forall a. Maybe a
Nothing
sqlBool (BoolAtom Bool
tf) = forall a. a -> Maybe a
Just Bool
tf
sqlBool Atom
x | Atom -> Bool
isSQLBool Atom
x = forall a. HasCallStack => [Char] -> a
error [Char]
"internal sqlBool type error" -- should be caught above
sqlBool Atom
other = forall a. HasCallStack => [Char] -> a
error ([Char]
"sqlBool type mismatch: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Atom
other)

nullAnd :: [Atom] -> Either AtomFunctionError Atom
nullAnd :: AtomFunctionBodyType
nullAnd [Atom
a,Atom
b] | Atom -> Bool
isSQLBool Atom
a Bool -> Bool -> Bool
&& Atom -> Bool
isSQLBool Atom
b = do
                  let bNull :: Atom
bNull = AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType forall a. Maybe a
Nothing
                      boolF :: Atom
boolF = AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType (forall a. a -> Maybe a
Just (Bool -> Atom
BoolAtom Bool
False))
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case (Atom -> Maybe Bool
sqlBool Atom
a, Atom -> Maybe Bool
sqlBool Atom
b) of
                             (Maybe Bool
Nothing, Maybe Bool
Nothing) -> Atom
bNull
                             (Maybe Bool
Nothing, Just Bool
True) -> Atom
bNull
                             (Maybe Bool
Nothing, Just Bool
False) -> Atom
boolF
                             (Just Bool
True, Maybe Bool
Nothing) -> Atom
bNull
                             (Just Bool
False, Maybe Bool
Nothing) -> Atom
boolF
                             (Just Bool
a', Just Bool
b') ->
                               AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType (forall a. a -> Maybe a
Just (Bool -> Atom
BoolAtom (Bool
a' Bool -> Bool -> Bool
&& Bool
b')))
nullAnd [Atom]
_other = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError

nullOr :: [Atom] -> Either AtomFunctionError Atom
nullOr :: AtomFunctionBodyType
nullOr [Atom
a,Atom
b] | Atom -> Bool
isSQLBool Atom
a Bool -> Bool -> Bool
&& Atom -> Bool
isSQLBool Atom
b = do
                let bNull :: Atom
bNull = AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType forall a. Maybe a
Nothing
                    boolTF :: Bool -> Atom
boolTF Bool
tf = AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType (forall a. a -> Maybe a
Just (Bool -> Atom
BoolAtom Bool
tf))
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case (Atom -> Maybe Bool
sqlBool Atom
a, Atom -> Maybe Bool
sqlBool Atom
b) of
                  (Maybe Bool
Nothing, Maybe Bool
Nothing) -> Atom
bNull
                  (Maybe Bool
Nothing, Just Bool
True) -> Bool -> Atom
boolTF Bool
True
                  (Maybe Bool
Nothing, Just Bool
False) -> Atom
bNull
                  (Just Bool
True, Maybe Bool
Nothing) -> Bool -> Atom
boolTF Bool
True
                  (Just Bool
False, Maybe Bool
Nothing) -> Atom
bNull
                  (Just Bool
a', Just Bool
b') -> Bool -> Atom
boolTF (Bool
a' Bool -> Bool -> Bool
|| Bool
b')
nullOr [Atom]
_other = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError                  
                
nullAtom :: AtomType -> Maybe Atom -> Atom
nullAtom :: AtomType -> Maybe Atom -> Atom
nullAtom AtomType
aType Maybe Atom
mAtom =
  case Maybe Atom
mAtom of
    Maybe Atom
Nothing -> TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"SQLNull" (AtomType -> AtomType
nullAtomType AtomType
aType) []
    Just Atom
atom -> TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"SQLJust" (AtomType -> AtomType
nullAtomType AtomType
aType) [Atom
atom]

isNullOrType :: AtomType -> Atom -> Bool
isNullOrType :: AtomType -> Atom -> Bool
isNullOrType AtomType
aType Atom
atom = Atom -> AtomType
atomTypeForAtom Atom
atom forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType AtomType
aType Bool -> Bool -> Bool
|| Atom -> AtomType
atomTypeForAtom Atom
atom forall a. Eq a => a -> a -> Bool
== AtomType
aType

isNull :: Atom -> Bool
isNull :: Atom -> Bool
isNull (ConstructedAtom TypeConstructorName
"SQLNull" (ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
_) []) = Bool
True
isNull (ConstructedAtom TypeConstructorName
"SQLNullOfUnknownType" (ConstructedAtomType TypeConstructorName
"SQLNullOfUnknownType" TypeVarMap
_) []) = Bool
True
isNull Atom
_ = Bool
False

isNullAtomType :: AtomType -> Bool
isNullAtomType :: AtomType -> Bool
isNullAtomType = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. AtomType -> Maybe AtomType
atomTypeFromSQLNull

atomTypeFromSQLNull :: AtomType -> Maybe AtomType
atomTypeFromSQLNull :: AtomType -> Maybe AtomType
atomTypeFromSQLNull (ConstructedAtomType TypeConstructorName
"SQLNullOfUnknownType" TypeVarMap
_) = forall a. Maybe a
Nothing
atomTypeFromSQLNull (ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
vars)
  | forall k a. Map k a -> Int
M.size TypeVarMap
vars forall a. Eq a => a -> a -> Bool
== Int
1 =
    case forall k a. Map k a -> [a]
M.elems TypeVarMap
vars of
      [] -> forall a. Maybe a
Nothing
      [AtomType
t] -> forall a. a -> Maybe a
Just AtomType
t
      [AtomType]
_ts -> forall a. Maybe a
Nothing
atomTypeFromSQLNull AtomType
_ = forall a. Maybe a
Nothing

sqlIntegerBinaryFunction :: AtomType -> (Integer -> Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom
sqlIntegerBinaryFunction :: AtomType -> (Integer -> Integer -> Atom) -> AtomFunctionBodyType
sqlIntegerBinaryFunction AtomType
expectedAtomType Integer -> Integer -> Atom
op [Atom
a,Atom
b] 
  | AtomType -> Atom -> Bool
isNullOrType AtomType
IntegerAtomType Atom
a Bool -> Bool -> Bool
&& AtomType -> Atom -> Bool
isNullOrType AtomType
IntegerAtomType Atom
b = do
    let extractVal :: Atom -> Maybe Integer
extractVal (ConstructedAtom TypeConstructorName
"SQLJust" AtomType
_ [IntegerAtom Integer
val]) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
val
        extractVal (IntegerAtom Integer
val) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
val
        extractVal (ConstructedAtom TypeConstructorName
"SQLNull" AtomType
_ []) = forall a. Maybe a
Nothing
        extractVal Atom
_ = forall a. Maybe a
Nothing
        mValA :: Maybe Integer
mValA = Atom -> Maybe Integer
extractVal Atom
a
        mValB :: Maybe Integer
mValB = Atom -> Maybe Integer
extractVal Atom
b
        inull :: Atom
inull = AtomType -> Maybe Atom -> Atom
nullAtom AtomType
expectedAtomType forall a. Maybe a
Nothing
    case (Maybe Integer
mValA, Maybe Integer
mValB) of
      (Maybe Integer
Nothing, Maybe Integer
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
inull
      (Maybe Integer
Nothing, Maybe Integer
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
inull
      (Maybe Integer
_, Maybe Integer
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
inull
      (Just Integer
valA, Just Integer
valB) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomType -> Maybe Atom -> Atom
nullAtom AtomType
expectedAtomType (forall a. a -> Maybe a
Just (Integer -> Integer -> Atom
op Integer
valA Integer
valB)))
sqlIntegerBinaryFunction AtomType
_ Integer -> Integer -> Atom
_ [Atom]
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError 

sqlIntegerUnaryFunction :: AtomType -> (Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom
sqlIntegerUnaryFunction :: AtomType -> (Integer -> Atom) -> AtomFunctionBodyType
sqlIntegerUnaryFunction AtomType
expectedAtomType Integer -> Atom
op [Atom
x]
  | AtomType -> Atom -> Bool
isNullOrType AtomType
IntegerAtomType Atom
x =
    case Atom
x of
      n :: Atom
n@(ConstructedAtom TypeConstructorName
"SQLNull" AtomType
_ []) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
n
      ConstructedAtom TypeConstructorName
"SQLJust" AtomType
_ [IntegerAtom Integer
val] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomType -> Maybe Atom -> Atom
nullAtom AtomType
expectedAtomType (forall a. a -> Maybe a
Just (Integer -> Atom
op Integer
val)))
      IntegerAtom Integer
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomType -> Maybe Atom -> Atom
nullAtom AtomType
expectedAtomType (forall a. a -> Maybe a
Just (Integer -> Atom
op Integer
val)))
      Atom
_other -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
sqlIntegerUnaryFunction AtomType
_ Integer -> Atom
_ [Atom]
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError       

sqlCount :: [Atom] -> Either AtomFunctionError Atom
sqlCount :: AtomFunctionBodyType
sqlCount [RelationAtom Relation
relIn] =
  case Relation -> RelationCardinality
cardinality Relation
relIn of
    Finite Int
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> Atom
IntegerAtom (forall a. Integral a => a -> Integer
toInteger Int
c)
    RelationCardinality
Countable -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
sqlCount [Atom]
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError

sqlAbs :: [Atom] -> Either AtomFunctionError Atom
sqlAbs :: AtomFunctionBodyType
sqlAbs [IntegerAtom Integer
val] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> Atom
IntegerAtom (forall a. Num a => a -> a
abs Integer
val)
sqlAbs [Atom
arg] | Atom
arg forall a. Eq a => a -> a -> Bool
== AtomType -> Maybe Atom -> Atom
nullAtom AtomType
IntegerAtomType forall a. Maybe a
Nothing =
               forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AtomType -> Maybe Atom -> Atom
nullAtom AtomType
IntegerAtomType forall a. Maybe a
Nothing
sqlAbs [ConstructedAtom TypeConstructorName
"SQLJust" AtomType
aType [IntegerAtom Integer
val]]
  | AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType =
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AtomType -> Maybe Atom -> Atom
nullAtom AtomType
IntegerAtomType (forall a. a -> Maybe a
Just (Integer -> Atom
IntegerAtom (forall a. Num a => a -> a
abs Integer
val)))
sqlAbs [Atom]
_other = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError         

sqlMax :: [Atom] -> Either AtomFunctionError Atom
sqlMax :: AtomFunctionBodyType
sqlMax = (Integer -> Integer -> Integer) -> AtomFunctionBodyType
sqlIntegerAgg forall a. Ord a => a -> a -> a
max

sqlMin :: [Atom] -> Either AtomFunctionError Atom
sqlMin :: AtomFunctionBodyType
sqlMin = (Integer -> Integer -> Integer) -> AtomFunctionBodyType
sqlIntegerAgg forall a. Ord a => a -> a -> a
min

sqlSum :: [Atom] -> Either AtomFunctionError Atom
sqlSum :: AtomFunctionBodyType
sqlSum = (Integer -> Integer -> Integer) -> AtomFunctionBodyType
sqlIntegerAgg forall a. Num a => a -> a -> a
(+)

sqlIntegerAgg :: (Integer -> Integer -> Integer) -> [Atom] -> Either AtomFunctionError Atom
sqlIntegerAgg :: (Integer -> Integer -> Integer) -> AtomFunctionBodyType
sqlIntegerAgg Integer -> Integer -> Integer
op [SubrelationFoldAtom Relation
relIn TypeConstructorName
subAttr] =
  case Relation -> Maybe RelationTuple
oneTuple Relation
relIn of
    Maybe RelationTuple
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AtomType -> Maybe Atom -> Atom
nullAtom AtomType
IntegerAtomType forall a. Maybe a
Nothing -- SQL max/min of empty table is NULL
    Just RelationTuple
oneTup ->
      if Atom -> AtomType
atomTypeForAtom (RelationTuple -> Atom
newVal RelationTuple
oneTup) forall a. Eq a => a -> a -> Bool
/= AtomType
IntegerAtomType then
        forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
        else
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (RelationTuple -> a -> a) -> a -> Relation -> a
relFold (\RelationTuple
tupIn Atom
acc -> Atom -> Atom -> Atom
nullMax Atom
acc (RelationTuple -> Atom
newVal RelationTuple
tupIn)) (RelationTuple -> Atom
newVal RelationTuple
oneTup) Relation
relIn
 where
   newVal :: RelationTuple -> Atom
newVal RelationTuple
tupIn =
      case TypeConstructorName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName TypeConstructorName
subAttr RelationTuple
tupIn of
        Left RelationalError
err -> forall a. HasCallStack => [Char] -> a
error (forall a. Show a => a -> [Char]
show RelationalError
err)
        Right Atom
atom -> Atom
atom
   nullMax :: Atom -> Atom -> Atom
nullMax Atom
acc Atom
nextVal =
     let mNextVal :: Maybe Integer
mNextVal = Atom -> Maybe Integer
sqlNullableIntegerToMaybe Atom
nextVal
         mOldVal :: Maybe Integer
mOldVal = Atom -> Maybe Integer
sqlNullableIntegerToMaybe Atom
acc
         mResult :: Maybe Integer
mResult = Integer -> Integer -> Integer
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
mNextVal forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Integer
mOldVal
         in
       AtomType -> Maybe Atom -> Atom
nullAtom AtomType
IntegerAtomType (case Maybe Integer
mResult of
                                    Maybe Integer
Nothing -> forall a. Maybe a
Nothing
                                    Just Integer
v -> forall a. a -> Maybe a
Just (Integer -> Atom
IntegerAtom Integer
v))
sqlIntegerAgg Integer -> Integer -> Integer
_ [Atom]
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError       
       

sqlNullableIntegerToMaybe :: Atom -> Maybe Integer
sqlNullableIntegerToMaybe :: Atom -> Maybe Integer
sqlNullableIntegerToMaybe (IntegerAtom Integer
i) = forall a. a -> Maybe a
Just Integer
i
sqlNullableIntegerToMaybe (ConstructedAtom TypeConstructorName
"SQLJust" AtomType
aType [IntegerAtom Integer
i]) | AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType = forall a. a -> Maybe a
Just Integer
i
sqlNullableIntegerToMaybe (ConstructedAtom TypeConstructorName
"SQLNull" AtomType
aType []) | AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType = forall a. Maybe a
Nothing
sqlNullableIntegerToMaybe (ConstructedAtom TypeConstructorName
"SQLNullOfUnknownType" AtomType
aType []) | AtomType
aType forall a. Eq a => a -> a -> Bool
== AtomType -> AtomType
nullAtomType AtomType
IntegerAtomType = forall a. Maybe a
Nothing
sqlNullableIntegerToMaybe Atom
_ = forall a. Maybe a
Nothing
           
-- check that types check out- Int and SQLNullable Int are OK, Int and SQLNullable Text are not OK
sqlEqualsTypes :: Atom -> Atom -> Bool
sqlEqualsTypes :: Atom -> Atom -> Bool
sqlEqualsTypes Atom
a Atom
b = Atom -> AtomType
underlyingType Atom
a forall a. Eq a => a -> a -> Bool
== Atom -> AtomType
underlyingType Atom
b
  where
    underlyingType :: Atom -> AtomType
underlyingType Atom
atom =
      let def :: AtomType
def = Atom -> AtomType
atomTypeForAtom Atom
atom 
      in  case Atom
atom of
            ConstructedAtom TypeConstructorName
x (ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
typmap) [Atom]
y ->
              let getSingle :: AtomType
getSingle = case forall k a. Map k a -> [a]
M.elems TypeVarMap
typmap of
                    [AtomType
z] -> AtomType
z
                    [AtomType]
_ -> AtomType
def 
              in  case (TypeConstructorName
x, [Atom]
y) of
                    (TypeConstructorName
"SQLNull", []) -> AtomType
getSingle 
                    (TypeConstructorName
"SQLJust", [Atom]
_) -> AtomType
getSingle
                    (TypeConstructorName, [Atom])
_ -> AtomType
def
            Atom
_ -> AtomType
def

sqlEquals :: AtomFunctionBodyType
sqlEquals :: AtomFunctionBodyType
sqlEquals [Atom
a,Atom
b] | Atom -> Atom -> Bool
sqlEqualsTypes Atom
a Atom
b =
  case (Atom -> Maybe Atom
maybeNullAtom Atom
a, Atom -> Maybe Atom
maybeNullAtom Atom
b) of
    (Maybe Atom
Nothing, Maybe Atom
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType forall a. Maybe a
Nothing
    (Maybe Atom
_, Maybe Atom
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType forall a. Maybe a
Nothing
    (Just Atom
a', Just Atom
b') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AtomType -> Maybe Atom -> Atom
nullAtom AtomType
BoolAtomType (forall a. a -> Maybe a
Just (Bool -> Atom
BoolAtom forall a b. (a -> b) -> a -> b
$ Atom
a' forall a. Eq a => a -> a -> Bool
== Atom
b'))
  where
      maybeNullAtom :: Atom -> Maybe Atom
maybeNullAtom (ConstructedAtom TypeConstructorName
"SQLJust" (ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
_) [Atom
atom]) = forall a. a -> Maybe a
Just Atom
atom
      maybeNullAtom (ConstructedAtom TypeConstructorName
"SQLNull" AtomType
_ []) = forall a. Maybe a
Nothing
      maybeNullAtom Atom
other = forall a. a -> Maybe a
Just Atom
other
sqlEquals [Atom]
_other = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError      

sqlIsNull :: AtomFunctionBodyType
sqlIsNull :: AtomFunctionBodyType
sqlIsNull [ConstructedAtom TypeConstructorName
"SQLNull" (ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
_) []] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Atom
BoolAtom Bool
True)
sqlIsNull [Atom
_arg] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Atom
BoolAtom Bool
False)
sqlIsNull [Atom]
_other = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError

isSQLNullableType :: AtomType -> Bool
isSQLNullableType :: AtomType -> Bool
isSQLNullableType (ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
_) = Bool
True
isSQLNullableType AtomType
_ = Bool
False

isSQLNullableSpecificType :: AtomType -> AtomType -> Bool
isSQLNullableSpecificType :: AtomType -> AtomType -> Bool
isSQLNullableSpecificType (ConstructedAtomType TypeConstructorName
"SQLNullable" TypeVarMap
vars) AtomType
expectedType | forall k a. Map k a -> [a]
M.elems TypeVarMap
vars forall a. Eq a => a -> a -> Bool
== [AtomType
expectedType] = Bool
True
isSQLNullableSpecificType AtomType
_ AtomType
_ = Bool
False

isSQLNullUnknownType :: AtomType -> Bool
isSQLNullUnknownType :: AtomType -> Bool
isSQLNullUnknownType AtomType
t = AtomType
t forall a. Eq a => a -> a -> Bool
== TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"SQLNullOfUnknownType" forall a. Monoid a => a
mempty