RosettaHaskellCompiler/src/Semantic/FunctionChecker.hs

module Semantic.FunctionChecker where

import Model.Function
import Model.Type
import Semantic.ExpressionChecker
import Semantic.TypeChecker
import Data.Either
import Data.Char
import Utils.Utils

-- |Checks if all the inputs and the output of a function call have valid types, and then checks that the assign-output expression is valid
checkFunction :: ([Type], [Symbol]) ->  Function -> Either [TypeCheckError] ExplicitFunction
checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name desc inp out) alias ex) =
    let checkedIn = checkAttributes definedTypes inp in
    if null $ lefts checkedIn
        then
            let symbolTable = addVariables symbols (rights checkedIn) in
            case addAliases definedTypes symbolTable alias of
                Left err -> Left [err]
                Right checkedAlias -> case head $ checkAttributes definedTypes [out] of
                    Left err -> Left [err]
                    Right checkedOut -> case checkAssignment definedTypes (addVariables (fst checkedAlias) [checkedOut]) ex of
                                Left err -> Left err
                                Right checkedEx -> Right $ MakeExplicitFunction (MakeFunctionSignature (toLower (head name) : tail name) desc (rights checkedIn) checkedOut) (snd checkedAlias) checkedEx
        else
            Left $ lefts checkedIn

checkAssignment :: [Type] -> [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)]
checkAssignment _ _ [] = Right []
checkAssignment defT symbs ((assign, ex): assigns) =
    -- Here we use only tail symbs, beacuse the head of the symbol table is the out variable, and that can't be used in the expression body
    case checkExpression defT (tail symbs) ex of
    Left err -> Left [err]
    Right checkedExp -> case checkExpression defT symbs assign of
        Left err -> Left [err]
        Right checkedA -> case checkAssignment defT symbs assigns of
                Left err -> Left err
                -- Add a final explicit transformation to match the expected output
                Right checked -> case returnCoercion checkedExp `coercionIncluded` returnCoercion checkedA of
                    Left err -> Left [err]
                    Right c -> Right $ (checkedA, changeCoercion checkedExp c) : checked

addAliases :: [Type] -> [Symbol] -> [(String, Expression)] -> Either TypeCheckError ([Symbol], [(String, ExplicitExpression)])
addAliases definedTypes symbolMap [] = Right (symbolMap, [])
addAliases definedTypes symbolMap (alias : aliases) = 
    case checkExpression definedTypes symbolMap (snd alias) of
        Left err -> Left err
        Right ex -> case add of
            Left err -> Left err
            Right added -> Right (fst added, (fst alias, ex) : snd added)
            where add = addAliases definedTypes (addVariables symbolMap [MakeTypeAttribute (fst alias) (coercionType $ typeCoercion $ returnCoercion ex) (toCardinality $ cardinalityCoercion $ returnCoercion ex) Nothing]) aliases