hssqlppp-0.1.0: Database/HsSqlPpp/AstInternals/TypeChecking/Expressions.ag
{-
Copyright 2009 Jake Wheat
This file contains the type checking code for the expression ast data
type.
-}
--gather the backtree, type errors and types together and add annotations
SEM Expression
| IntegerLit StringLit FloatLit BooleanLit NullLit FunCall Identifier
Exists Case CaseSimple Cast InPredicate ScalarSubQuery LiftOperator
PositionalArg Placeholder WindowFn
lhs.annotatedTree = annTypesAndErrors @loc.backTree
(tpeToT @loc.tpe)
(getErrors @loc.tpe)
Nothing
{-
== literals
pretty straightforward
-}
SEM Expression
| IntegerLit loc.tpe = Right typeInt
| StringLit loc.tpe = Right UnknownType
| FloatLit loc.tpe = Right typeNumeric
| BooleanLit loc.tpe = Right typeBool
-- I think a null has the same type resolution as an unknown string lit
| NullLit loc.tpe = Right UnknownType
SEM Expression
| IntegerLit
loc.backTree = IntegerLit @ann @i
| StringLit
loc.backTree = StringLit @ann @quote @value
| FloatLit
loc.backTree = FloatLit @ann @d
| BooleanLit
loc.backTree = BooleanLit @ann @b
| NullLit
loc.backTree = NullLit @ann
{-
== cast expression
all the work is done in the typename node
-}
SEM Expression
| Cast loc.tpe = Right $ @tn.namedType
loc.backTree = Cast @ann @expr.annotatedTree @tn.annotatedTree
{-
== operators and functions
-}
SEM Expression
| FunCall
loc.tpe = dependsOnRTpe @args.typeList $
typeCheckFunCall
@lhs.env
@funName
@args.typeList
loc.backTree = FunCall @ann @funName @args.annotatedTree
| WindowFn
loc.tpe = Right (getTypeAnnotation @fn.annotatedTree)
loc.backTree = WindowFn @ann
@fn.annotatedTree
@partitionBy.annotatedTree
@orderBy.annotatedTree
@dir.annotatedTree
@frm.annotatedTree
{
{-
small shim in front of findCallMatch in the type conversion code, to
handle some special cases.
Some of the special cases will no longer be needed when variadic
support is added.
between, greatest and least are treated as syntactic sugar so we
delegate the function lookups to the <=/>= operators.
the row comparison should be more general than this, since it supports
any operator satisfying some properties
TODO: move all of this into find call match. Don't know why it's separate
-}
typeCheckFunCall :: Environment -> String -> [Type] -> Either [TypeError] Type
typeCheckFunCall env fnName' argsType =
{-trace ("typecheckfncall " ++ fnName' ++ show argsType) $-}
dependsOnRTpe argsType $
case fnName of
"count" -> -- not quite sure how this is suppose to work,
-- the counts in the pg catalog accept either
-- no args, or one arg of type any, but you can call
-- count with multiple arguments?
return typeBigInt
"!between" -> do
f1 <- lookupFn ">=" [argsType !! 0, argsType !! 1]
f2 <- lookupFn "<=" [argsType !! 0, argsType !! 2]
lookupFn "!and" [f1,f2]
--"coalesce" -> resolveResultSetType env argsType
"greatest" -> do
t <- lookupFn fnName argsType -- t <- resolveResultSetType env argsType
lookupFn ">=" [t,t]
return t
"least" -> do
t <- lookupFn fnName argsType -- resolveResultSetType env argsType
lookupFn "<=" [t,t]
return t
"!rowctor" -> return $ AnonymousRecordType argsType
-- special case the row comparison ops
-- this needs to be fixed: we want to match
-- any implicit casts to functions on composite types
-- first, then we can use the anonymous record type on
-- any composite
_ | fnName `elem` ["=", "<>", "<=", ">=", "<", ">"]
&& length argsType == 2
&& all isCompositeOrSetOfCompositeType argsType
&& compositesCompatible env (head argsType) (head $ tail argsType) -> Right typeBool
--checked for all special cases, so run general case now
s -> lookupFn s argsType
where
lookupFn :: String -> [Type] -> Either [TypeError] Type
lookupFn s1 args = do
(_,_,r,_) <- findCallMatch env
(if s1 == "u-" then "-" else s1) args
return r
checkRowTypesMatch (AnonymousRecordType t1s) (AnonymousRecordType t2s) = do
when (length t1s /= length t2s) $ Left [ValuesListsMustBeSameLength]
let errs = map (resolveResultSetType env . (\(a,b) -> [a,b])) $
zip t1s t2s
liftErrors $ concat $ lefts errs
return typeBool
checkRowTypesMatch x y =
error $ "internal error: checkRowTypesMatch called with " ++
show x ++ "," ++ show y
fnName = map toLower fnName'
}
{-
lifted operator:
pretty much the same as haskell 'any (lhs [op]) rhss' (or all instead of any)
where lhs is the first argument and rhss is the second argument
which must be an array
pg allows the rhss to also be a subselect, this is a todo
-}
SEM Expression
| LiftOperator
loc.tpe = dependsOnRTpe @args.typeList $ do
let args = @args.annotatedTree
errorWhen (length args /= 2)
[AnyAllError $ "must have two args, got " ++ show args]
let [a,b] = args
aType = getTypeAnnotation a
bType = getTypeAnnotation b
dependsOnRTpe [aType,bType] $ do
errorWhen (not $ isArrayType bType)
[AnyAllError $ "second arg must be array, got " ++ show args]
elemType <- unwrapArray $ bType
resType <- typeCheckFunCall
@lhs.env
@oper
[aType,elemType]
errorWhen (resType /= typeBool)
[AnyAllError $ "operator must have bool return, got " ++ show resType]
return resType
loc.backTree = LiftOperator @ann @oper @flav.annotatedTree @args.annotatedTree
{-
== case expression
for non simple cases, we need all the when expressions to be bool, and
then to collect the types of the then parts to see if we can resolve a
common type
for simple cases, we need to check all the when parts have the same type
as the value to check against, then we collect the then parts as above.
-}
SEM Expression
| Case CaseSimple
loc.whenTypes = map getTypeAnnotation $ concatMap fst $
@cases.annotatedTree
loc.thenTypes = map getTypeAnnotation $
(map snd $ @cases.annotatedTree) ++
maybeToList @els.annotatedTree
SEM Expression
| Case
loc.tpe =
dependsOnRTpe @loc.whenTypes $ do
errorWhen (any (/= typeBool) @loc.whenTypes) $
[WrongTypes typeBool @loc.whenTypes]
dependsOnRTpe @loc.thenTypes $
resolveResultSetType @lhs.env @loc.thenTypes
loc.backTree = Case @ann @cases.annotatedTree @els.annotatedTree
SEM Expression
| CaseSimple
loc.tpe =
dependsOnRTpe @loc.whenTypes $ do
let valueType = getTypeAnnotation @value.annotatedTree
checkWhenTypes <-
resolveResultSetType @lhs.env (valueType : @loc.whenTypes)
dependsOnRTpe @loc.thenTypes $
resolveResultSetType @lhs.env @loc.thenTypes
loc.backTree = CaseSimple @ann
@value.annotatedTree
@cases.annotatedTree
@els.annotatedTree
{-
== identifiers
pull id types out of env for identifiers
-}
SEM Expression
| Identifier
loc.tpe = libLookupID @lhs.lib @i
loc.backTree = Identifier @ann @i
SEM Expression
| PositionalArg
loc.tpe = libLookupID @lhs.lib ('$':show @p)
loc.backTree = PositionalArg @ann @p
SEM Expression
| Placeholder
loc.tpe = Right UnknownType
loc.backTree = Placeholder @ann
-- exists: will work on any subselect so we don't need to do any checking
SEM Expression
| Exists
loc.tpe = Right typeBool
loc.backTree = Exists @ann @sel.annotatedTree
{-
== scalar subquery
1 col -> type of that col
2 + cols -> row type
-}
SEM Expression
| ScalarSubQuery
loc.tpe =
do
let selType = getTypeAnnotation @sel.annotatedTree
dependsOnRTpe [selType] $ do
f <- map snd <$> unwrapSetOfComposite selType
case length f of
0 -> Left [InternalError "no columns in scalar subquery?"]
1 -> Right $ head f
_ -> Right $ AnonymousRecordType f
loc.backTree = ScalarSubQuery @ann @sel.annotatedTree
{-
== inlist
todo: make the ast and typechecking a special case of lifted operator
-}
SEM Expression
| InPredicate
loc.tpe = do
lt <- @list.listType
ty <- resolveResultSetType
@lhs.env
[getTypeAnnotation @expr.annotatedTree, lt]
return typeBool
loc.backTree = InPredicate @ann
@expr.annotatedTree
@i
@list.annotatedTree
ATTR InList [||listType : {Either [TypeError] Type}]
SEM InList
| InList
lhs.listType = resolveResultSetType @lhs.env @exprs.typeList
| InSelect
lhs.listType =
do
attrs <- map snd <$> (unwrapSetOfComposite $
getTypeAnnotation @sel.annotatedTree)
typ <- case length attrs of
0 -> Left [InternalError
"got subquery with no columns? in inselect"]
1 -> Right $ head attrs
_ -> Right $ AnonymousRecordType attrs
dependsOnRTpe attrs $ Right typ