module CSVQLTypes where

import CSVQLGrammar
import System.IO

-- variable name, type
type VariableTypeMap = [(String, UnTypes)]

-- function name, function parent type, function return type
type BuiltInTypeMap = [(String, [UnTypes], UnTypes)]
data UnTypes = TypeNull | TypeInt | TypeBool | TypeString | Iterable Iterables deriving (Eq, Show)
data Iterables = TypeRow | TypeTable | TypeList UnTypes deriving (Eq, Show)

-- see what type a given expression is
getType :: E -> VariableTypeMap -> BuiltInTypeMap -> UnTypes
getType (For _ _ _) _ _ = TypeNull -- things that dont need to return anything
getType (Int _) _ _ = TypeInt
getType (String _) _ _ = TypeString
getType (Semi _ e2) v f = getType e2 v f
getType (Sub _ funcName _) _ fmap = do
    let func = fOutputTypeLookup fmap funcName
    case func of
        Just fType -> fType
        _ -> error ("ERROR: Function \"" ++ funcName ++ "\" does not exist.")
getType (Func fname _) v fmap = do
    let func = fOutputTypeLookup fmap fname
    case func of
        Just fType -> fType
        _ -> error ("ERROR: Function \"" ++ fname ++ "\" does not exist.")
getType (ListBody e1 e2) v f = getType e2 v f --recurses down
getType (Var name) vars _ = do
    let var = lookupVarType name vars
    case var of
        Just v -> v
        _ -> error ("ERROR: Variable \"" ++ name ++ "\" does not exist.")
getType (Assign _ e) v _ = TypeNull --doesnt return anything
getType (If e1 e2) v f = getType e2 v f
getType (IfElse e1 e2 e3) v f | getType e2 v f == getType e3 v f = getType e2 v f
                              | otherwise = error "ERROR: One of your IfElse statements does not return the same type in the If and Else brackets."
getType (Equals _ _) _ _ = TypeBool
getType (Bool _) _ _ = TypeBool
getType (List e1) v f = Iterable (TypeList (getType e1 v f))
getType Null _ _ = TypeNull
getType (Row _) _ _ = Iterable TypeRow --probably??
getType (Table _ _) _ _ = Iterable TypeTable
getType (Index x y) v f = getType x v f
getType (Not _) _ _ = TypeBool -- since Not negates a boolean it itself returns a bool
getType (And _ _) _ _ = TypeBool
getType (Or _ _) _ _ = TypeBool
getType (LessThan _ _) _ _ = TypeBool
getType (GreaterThan _ _) _ _ = TypeBool


-- make sure a type for a given expression is correct
typesValid :: E -> VariableTypeMap -> BuiltInTypeMap -> IO (Bool, VariableTypeMap)
typesValid (Bool _) v _ = return (True, v)
typesValid (Int _) v _ = return (True, v)
typesValid (String _) v _ = return (True, v)
typesValid (Var _) v _ = return (True, v)
typesValid Null v _ = return (True, v)
-- etc etc; true for all of the base cases as they dont need further proving
typesValid (If expr1 expr2) vars fmap = do
    (valid1, vars') <- typesValid expr1 vars fmap
    (valid2, vars'') <- typesValid expr2 vars' fmap
    case (valid1, valid2) of
        (True, True) -> do
            let type1 = getType expr1 vars fmap
            case type1 of
                TypeBool -> return (True, vars'')
                _ -> do
                    hPutStrLn stderr $ "ERROR: One of your If statements contains a " ++ show type1 ++ " instead of a Bool."
                    return (False, vars'')
        (False, False) -> do
            hPutStrLn stderr "ERROR: One of your If statements has an invalid conditional expression and consequent function."
            return (False, vars'')
        (False, _) -> do
            hPutStrLn stderr "ERROR: One of your If statements has an invalid conditional expression."
            return (False, vars'')
        (_, False) -> do
            hPutStrLn stderr "ERROR: One of your If statements has an invalid consequent function."
            return (False, vars'')
typesValid (IfElse e1 e2 e3) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    (v3, _) <- typesValid e3 vars fmap
    case (v1, v2, v3) of
        (True, True, True) -> do
            let type1 = getType e1 vars fmap
            let type2 = getType e2 vars fmap
            let type3 = getType e3 vars fmap
            let matching = type2 == type3
            case (type1, matching) of
                (TypeBool, True) -> return (True, vars)
                (TypeBool, _) -> do
                    hPutStrLn stderr "ERROR: Return types of an IfElse body do not match."
                    return (False, vars)
                _ -> do
                    hPutStrLn stderr ("ERROR: One of your IfElse statements contains a " ++ show type1 ++ " instead of a Bool.")
                    return (False, vars)
        (False, False, False) -> do
            hPutStrLn stderr "ERROR: One of your IfElse statements has an invalid conditional expression, consequent function, and alternate function. How impressive."
            return (False, vars)
        (False, False, _) -> do
            hPutStrLn stderr "ERROR: One of your IfElse statements has an invalid conditional expression and consequent function."
            return (False, vars)
        (False, _, False) -> do
            hPutStrLn stderr "ERROR: One of your IfElse statements has an invalid conditional expression and alternate function."
            return (False, vars)
        (_, False, False) -> do
            hPutStrLn stderr "ERROR: One of your IfElse statements has an invalid consequent function and alternate function."
            return (False, vars)
        (False, _, _) -> do
            hPutStrLn stderr "ERROR: One of your IfElse statements has an invalid conditional expression."
            return (False, vars)
        (_, False, _) -> do
            hPutStrLn stderr "ERROR: One of your IfElse statements has an invalid consequent function."
            return (False, vars)
        (_, _, False) -> do
            hPutStrLn stderr "ERROR: One of your IfElse statements has an invalid alternate function."
            return (False, vars)
typesValid (Equals e1 e2) vars fmap = do
    (v1, vars') <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> return (True, vars')
        (False, False) -> do
            hPutStrLn stderr "ERROR: One of your == statements has an invalid type on both sides."
            return (False, vars')
        (False, _) -> do
            hPutStrLn stderr "ERROR: One of your == statements has an invalid type on the left."
            return (False, vars')
        (_, False) -> do
            hPutStrLn stderr "ERROR: One of your == statements has an invalid type on the right."
            return (False, vars')
typesValid (LessThan e1 e2) vars fmap = do
    (v1, vars') <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> do
            let t1 = getType e1 vars fmap
            let t2 = getType e2 vars fmap
            case (t1, t2) of
                (TypeInt, TypeInt) -> return (True, vars)
                _ -> do
                    hPutStrLn stderr $ "ERROR: '<' expression comparing non-ints."
                    return (False, vars)
        (False, _) -> do
            hPutStrLn stderr $ "ERROR: Left side of '<' expression has invalid types."
            return (False, vars)
        (_, False) -> do
            hPutStrLn stderr $ "ERROR: Left side of '<' expression has invalid types."
            return (False, vars)
typesValid (GreaterThan e1 e2) vars fmap = do
    (v1, vars') <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> do
            let t1 = getType e1 vars fmap
            let t2 = getType e2 vars fmap
            case (t1, t2) of
                (TypeInt, TypeInt) -> return (True, vars)
                _ -> do
                    hPutStrLn stderr $ "ERROR: '>' expression comparing non-ints."
                    return (False, vars)
        (False, _) -> do
            hPutStrLn stderr $ "ERROR: Left side of '>' expression has invalid types."
            return (False, vars)
        (_, False) -> do
            hPutStrLn stderr $ "ERROR: Left side of '>' expression has invalid types."
            return (False, vars)

typesValid (For e1 e2 e3) vars fmap = do
    let v2 = lookupVarType e2 vars
    case v2 of
        Just (Iterable t) -> do
            case t of
                TypeRow -> do
                    (v3, vars') <- typesValid e3 ((e1, TypeString):vars) fmap
                    case v3 of
                        True -> return (True, vars')
                        _ -> do
                            hPutStrLn stderr ("ERROR: One of your For loops iterates over Row \"" ++ e2 ++ "\" which has an invalid body.")
                            return (False, vars')
                TypeTable -> do
                    (v3, vars') <- typesValid e3 ((e1, Iterable TypeRow):vars) fmap
                    case v3 of
                        True -> return (True, vars')
                        _ -> do
                            hPutStrLn stderr ("ERROR: One of your For loops iterates over Table \"" ++ e2 ++ "\" which has an invalid body.")
                            return (False, vars')
                TypeList x -> do
                    (v3, vars') <- typesValid e3 ((e1, x):vars) fmap
                    case v3 of
                        True -> return (True, vars')
                        _ -> do
                            hPutStrLn stderr ("ERROR: One of your For loops iterates over List \"" ++ e2 ++ "\" which has an invalid body.")
                            return (False, vars')
        _ -> do
            hPutStrLn stderr ("ERROR: One of your For loops tries to iterate over \"" ++ e2 ++ "\" which is of a non-iterable type.")
            return (False, vars)
typesValid (Semi e1 e2) vars fmap = do
    (v1, vars') <- typesValid e1 vars fmap
    (v2, vars'') <- typesValid e2 vars' fmap
    case (v1, v2) of
        (True, True) -> return (True, vars'')
        _ -> return (False, vars'')
typesValid (ListBody e1 e2) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> return (True, vars)
        _ -> return (False, vars)
    -- let sameType = getType e1 vars == getType e2 vars
    -- case (v1, v2, sameType) of
    --     (True, True, True) -> True
    --     _ -> False
typesValid (Assign name e1) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    case v1 of
        True -> return (True, (name, t):vars)
            where t = getType e1 vars fmap
        _ -> do
            hPutStrLn stderr ("ERROR: One of your Assign statements tries to assign \"" ++ name ++ "\" to an invalid expression.")
            return (False, vars)
typesValid (List e1) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    case v1 of
        True -> return (True, vars)
        _ -> do
            hPutStrLn stderr "ERROR: One of your Lists contains an invalid expression."
            return (False, vars)
typesValid (Row e1) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    case v1 of
        True -> if checkListBody vars (TypeString) e1
                    then return (True, vars)
                    else do
                        hPutStrLn stderr "ERROR: One of your Rows contains a variable that isn't a String."
                        return (False, vars)
        _ -> do
            hPutStrLn stderr "ERROR: One of your Rows contains an invalid expression."
            return (False, vars)
typesValid (Table e1 e2) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> if (checkListBody vars (Iterable TypeRow) e2 || getType e2 vars [] == TypeNull ) -- do "check if table has int and contains rows"
                            then return (True, vars)
                            else do
                                hPutStrLn stderr "ERROR: One of your Tables contains something that isn't a Row"
                                return (False, vars)
        _ -> do
            hPutStrLn stderr "ERROR: One of your Tables contains an invalid expression."
            return (False, vars)
typesValid (Not e1) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    case v1 of
        True -> do
            let type1 = getType e1 vars fmap
            case type1 of
                TypeBool -> return (True, vars)
                _ -> do
                    hPutStrLn stderr ("ERROR: One of your Not statements contains a " ++ show type1 ++ " rather than a Bool.")
                    return (False, vars)
        _ -> do
            hPutStrLn stderr "ERROR: One of your Not statements contains an invalid expression."
            return (False, vars)
typesValid (Index e1 e2) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap 
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> do
            let type1 = getType e1 vars fmap --uh is this needed?
            let type2 = getType e2 vars fmap
            case type2 of 
                TypeInt -> return (True, vars)
                _ -> do
                    hPutStrLn stderr ("ERROR: One of your Index statements contains a " ++ show type2 ++ " rather than the expected Int for the index number.")
                    return (False, vars)
        (False, _) -> do
                    hPutStrLn stderr "ERROR: One of your Index statements tries to get the index of an invalid expression."
                    return (False, vars)
        _ -> do
            hPutStrLn stderr "ERROR: You managed to provide something other than an Int for the index number. And it's not a valid expression. Impressive."
            return (False, vars)
typesValid subExpr@(Sub parentName childName e3) vars fmap = do
    let parentType = getType (Var parentName) vars fmap
    let fTypes = fInputTypeLookup fmap childName
    -- let childType = getType subExpr vars fmap
    case (parentType, fTypes) of
        (pType, Just fTypes') -> do
            let matching = parentType `elem` fTypes'
            (v3, _) <- typesValid e3 vars fmap
            case (matching, v3) of
                (True, True) -> return (True, vars)
                (False, _) -> do
                    hPutStrLn stderr ("ERROR: Function \"" ++ childName ++ "\" cannot be used on " ++ show parentType ++ ".")
                    return (False, vars)
                (_, False) -> do
                    hPutStrLn stderr ("ERROR: Function \"" ++ childName ++ "\" contains invalid arguments.")
                    return (False, vars)
        _ -> do
            hPutStrLn stderr ("ERROR: Function \"" ++ childName ++ "\" does not exist.")
            return (False, vars)
typesValid plusExpr@(Plus e1 e2) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap 
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> do
            let t1 = getType e1 vars fmap
            let t2 = getType e2 vars fmap
            case (t1, t2) of
                (Iterable TypeRow, Iterable TypeRow) -> return (True, vars)
                (TypeInt, TypeInt) -> return (True, vars)
                (TypeInt, Iterable TypeRow) -> do
                    hPutStrLn stderr "ERROR: You cannot add an Int and a Row together."
                    return (False, vars)
                (Iterable TypeRow, TypeInt) -> do
                    hPutStrLn stderr "ERROR: You cannot add an Int and a Row together."
                    return (False, vars)
                (_, TypeInt) -> do
                    hPutStrLn stderr ("ERROR: " ++ show t1 ++ " is not valid in a Plus expression.")
                    return (False, vars)
                (_, Iterable TypeRow) -> do
                    hPutStrLn stderr ("ERROR: " ++ show t1 ++ " is not valid in a Plus expression.")
                    return (False, vars)
                (TypeInt, _) -> do
                    hPutStrLn stderr ("ERROR: " ++ show t2 ++ " is not valid in a Plus expression.")
                    return (False, vars)
                (Iterable TypeRow, _) -> do
                    hPutStrLn stderr ("ERROR: " ++ show t2 ++ " is not valid in a Plus expression.")
                    return (False, vars)
                _ -> do
                    hPutStrLn stderr ("ERROR: Neither " ++ show t1 ++ " nor " ++ show t2 ++ " are valid in a Plus expression.")
                    return (False, vars)
        _ -> do
            hPutStrLn stderr "ERROR: One of your Plus statements contains an invalid expression."
            return (False, vars)
typesValid (And e1 e2) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> do
            let t1 = getType e1 vars fmap
            let t2 = getType e2 vars fmap
            case (t1, t2) of
                (TypeBool, TypeBool) -> return (True, vars)
                (_, TypeBool) -> do
                    hPutStrLn stderr ("ERROR: One of your And statements contains a " ++ show t1 ++ " rather than a Bool as the first variable.")
                    return (False, vars)
                (TypeBool, _) -> do
                    hPutStrLn stderr ("ERROR: One of your And statements contains a " ++ show t2 ++ " rather than a Bool as the second variable.")
                    return (False, vars)
                (_, _) -> do
                    hPutStrLn stderr ("ERROR: One of your And statements contains a " ++ show t1 ++ " and a " ++ show t2 ++ " rather Bools as variables.")
                    return (False, vars)
        _ -> do
            hPutStrLn stderr "ERROR: One of your And statements contains an invalid expression."
            return (False, vars)
typesValid (Or e1 e2) vars fmap = do
    (v1, _) <- typesValid e1 vars fmap
    (v2, _) <- typesValid e2 vars fmap
    case (v1, v2) of
        (True, True) -> do
            let t1 = getType e1 vars fmap
            let t2 = getType e2 vars fmap
            case (t1, t2) of
                (TypeBool, TypeBool) -> return (True, vars)
                (_, TypeBool) -> do
                    hPutStrLn stderr ("ERROR: One of your Or statements contains a " ++ show t1 ++ " rather than a Bool as the first variable.")
                    return (False, vars)
                (TypeBool, _) -> do
                    hPutStrLn stderr ("ERROR: One of your Or statements contains a " ++ show t2 ++ " rather than a Bool as the second variable.")
                    return (False, vars)
                (_, _) -> do
                    hPutStrLn stderr ("ERROR: One of your Or statements contains a " ++ show t1 ++ " and a " ++ show t2 ++ " rather Bools as variables.")
                    return (False, vars)
        _ -> do
            hPutStrLn stderr "ERROR: One of your Or statements contains an invalid expression."
            return (False, vars)
typesValid (Func name args) vars fmap = do
    (valid, _) <- typesValid args vars fmap
    if valid
        then return (True, vars)
        else do
            hPutStrLn stderr ("ERROR: Function \"" ++ name ++ "\" contains invalid arguments.")
            return (False, vars)
   


-- get a type assigned to a variable
lookupVarType :: String -> VariableTypeMap -> Maybe UnTypes
lookupVarType = lookup

-- find type for function
fInputTypeLookup :: BuiltInTypeMap -> String -> Maybe [UnTypes]
fInputTypeLookup [] _ = Nothing
fInputTypeLookup ((x, fInputType, _):fMap) name | name == x = Just fInputType
                                  | otherwise = fInputTypeLookup fMap name

fOutputTypeLookup :: BuiltInTypeMap -> String -> Maybe UnTypes
fOutputTypeLookup [] _ = Nothing
fOutputTypeLookup ((x, _, outType):fMap) name | name == x = Just outType
                                              | otherwise = fOutputTypeLookup fMap name

checkListBody :: VariableTypeMap -> UnTypes -> E -> Bool
checkListBody v t (ListBody e1 e2) = getType e1 v [] == t && checkListBody v t e2
checkListBody v t e1 = getType e1 v [] == t