{-


This file contains the ag code for create function statements.

    | CreateFunction ann:Annotation
                     name : String
                     params : ParamDefList
                     rettype : TypeName
                     rep : Replace
                     lang : Language
                     body : FnBody
                     vol : Volatility

DATA FnBody | SqlFnBody ann:Annotation sts : StatementList
            | PlpgsqlFnBody ann:Annotation vars:VarDefList sts : StatementList

DATA ParamDef | ParamDef ann:Annotation name:String typ:TypeName
              | ParamDefTp ann:Annotation typ:TypeName

DATA VarDef | VarDef ann:Annotation
                     name : String
                     typ : TypeName
                     value : (Maybe Expression)

paramdeflist: need cat, produces lb
vardef needs cat, produces lb
function body: gets cat and new lb

-}
{
data ParamName = NamedParam Int String
               | UnnamedParam Int
}

ATTR ParamDef [pos : Int||paramName : ParamName
                          namedType : {Maybe Type}]

ATTR ParamDefList [pos : Int||params : {[(ParamName, Maybe Type)]}]


-- collect the information to update the local bindings from the parameters
SEM ParamDef
    | ParamDef ParamDefTp
        lhs.namedType = @typ.namedType
    | ParamDef
        lhs.paramName = NamedParam @lhs.pos (ncStr @name)
    | ParamDefTp
        lhs.paramName = UnnamedParam @lhs.pos

SEM ParamDefList
     | Nil lhs.params = []
     | Cons lhs.params = ((@hd.paramName, @hd.namedType) : @tl.params)
            hd.pos = @lhs.pos
            tl.pos = @lhs.pos + 1

-- create the new local bindings and pass into the function body
-- just

SEM Statement
    | CreateFunction
        --add the parameters to the catalog for the contained statements
        body.lib = either (const @lhs.lib) id $ do
                   _ <- lmt @rettype.namedType
                   lbUpdate @lhs.cat (LBIds ((getTName @name.originalTree) ++ " parameters") (Just (getTName @name.originalTree)) paramsNoPos) @lhs.lib
                   >>= lbUpdate @lhs.cat (LBIds ((getTName @name.originalTree) ++ " parameters") Nothing paramsPosOnly)
                   where
                     paramsPosOnly :: [(String,Type)]
                     paramsPosOnly = mapMaybe prm @params.params
                     prm :: (ParamName,Maybe Type) -> Maybe (String,Type)
                     prm (NamedParam p _,Just t) = Just ("$" ++ show p, t)
                     prm (UnnamedParam p,Just t) = Just ("$" ++ show p, t)
                     prm _ = Nothing
                     paramsNoPos :: [(String,Type)]
                     paramsNoPos = mapMaybe pnp @params.params
                     pnp :: (ParamName,Maybe Type) -> Maybe (String,Type)
                     pnp (NamedParam _ n,Just t) = Just (n,t)
                     pnp _ = Nothing
        params.pos = 1

{-
boilerplate

-}

SEM Statement
    | CreateFunction
        loc.tpe = Right $ Pseudo Void
        loc.catUpdates = either (const []) id $ do
                         let ps = mapMaybe lpt @params.params
                         rt <- lmt @rettype.namedType
                         return [CatCreateFunction FunName
                                                   (map toLower (getTName @name.originalTree))
                                                   ps
                                                   rt
                                                   False]
                         where
                           lpt (_,Just t) = Just t
                           lpt _ = Nothing

        loc.backTree = CreateFunction @ann
                                      @name.originalTree
                                      @params.annotatedTree
                                      @rettype.annotatedTree
                                      @rep
                                      @lang
                                      @body.annotatedTree
                                      @vol
        loc.statementType = Nothing
        body.cat = @lhs.inProducedCat




{-


== function prototype

all you do here is type check enough to produce the prototype
information which is added to the catalog, this means the function
name, parameter types, and the return type.

type checking failure is contained so that the function prototype is
produced iff the parameter and return types check ok. Any type errors
in the function body (including the top level variable declarations
don't affect the prototype, and hence callers of the function).

-}




{-
ISSUE:

when writing an sql file, you can put a create function which refers
to a table definition that is given later. As long as the function
isn't called before the table definition is given, this is ok. To
handle this, need to gather the function prototype, but delay checking
the contents until either a) all the other type checking has been
done, or b) the function is needed (list ways this can happen: used in
a view (even then, not needed until view is used), function can be
called directly, or indirectly in another function call, ...)

No thoughts on how to do this - but at some point want to support
'declarative' sql source code, where the order doesn't matter, and
this code figures out an order to load it into the database which will
get past pgs checks, so hopefully the solution will move towards this
goal also. One additional consideration is that the error message in a
situation like this would be really helpful if it could tell that a
problem like this could be fixed with a reordering, and suggest that
reordering.

New plan: do two passes, type check everything but the bodies of
functions in first pass, then type check bodies of functions in second
pass. Not perfect, but better than current situation. This will be
achieved by using a separate cat attribute which is the same as the cat
value which gets returned from the annotation functions in AstInternal.ag

-}

{-
TODO: using fromRight on it's own for identifier bindings or cat
updates is wrong, if an error is produced then this needs to be added
to an annotation somewhere. Some of the code uses error instead of fromRight
which is even worse.
-}