AstInternal.ag

{-
Copyright 2009 Jake Wheat

This file contains the ast nodes, and the api functions to pass an ast
and get back type information.

It uses the Utrecht University Attribute Grammar system:

http://www.cs.uu.nl/wiki/bin/view/HUT/AttributeGrammarSystem
http://www.haskell.org/haskellwiki/The_Monad.Reader/Issue4/Why_Attribute_Grammars_Matter

The attr and sem definitions are in TypeChecking.ag, which is included
into this file.

These ast nodes are both used as the result of successful parsing, and
as the input to the type checker (and the output from the type
checker), and the pretty printer.

= compiling

use

uuagc  -dcfwsp --cycle --genlinepragmas AstInternal.ag

to generate a new AstInternal.hs from this file (cycle will check for
cycles - it's bad if you get any of these, and genlinepragmas mean
that you'll be able to view the original source ag positions when
there are errors or warnings compiling the generated hs file, which
you want much more often than not).

(install uuagc with
cabal install uuagc
)

-}
MODULE {Database.HsSqlPpp.AstInternals.AstInternal}
{
    -- {-# LANGUAGE DeriveDataTypeable,RankNTypes,ScopedTypeVariables #-}
    -- {-# OPTIONS_HADDOCK hide  #-}
    --from the ag files:
    --ast nodes
    Statement (..)
   ,SelectExpression (..)
   ,FnBody (..)
   ,SetClause (..)
   ,TableRef (..)
   ,JoinExpression (..)
   ,JoinType (..)
   ,SelectList (..)
   ,SelectItem (..)
   ,CopySource (..)
   ,AttributeDef (..)
   ,RowConstraint (..)
   ,Constraint (..)
   ,TypeAttributeDef (..)
   ,ParamDef (..)
   ,VarDef (..)
   ,RaiseType (..)
   ,CombineType (..)
   ,Volatility (..)
   ,Language (..)
   ,TypeName (..)
   ,DropType (..)
   ,Cascade (..)
   ,Direction (..)
   ,Distinct (..)
   ,Natural (..)
   ,IfExists (..)
   ,RestartIdentity (..)
   ,Expression (..)
   ,InList (..)
   ,StatementList
   ,ExpressionListStatementListPairList
   ,ExpressionListStatementListPair
   ,ExpressionList
   ,StringList
   ,ParamDefList
   ,AttributeDefList
   ,ConstraintList
   ,TypeAttributeDefList
   ,StringStringListPairList
   ,StringStringListPair
   ,ExpressionStatementListPairList
   ,SetClauseList
   ,CaseExpressionListExpressionPairList
   ,MaybeExpression
   ,TableRefList
   ,ExpressionListList
   ,SelectItemList
   ,OnExpr
   ,RowConstraintList
   ,VarDefList
   ,ExpressionStatementListPair
   ,CaseExpressionListExpressionPair
   ,CaseExpressionList
   ,ExpressionDirectionPair
   ,ExpressionDirectionPairList
   ,MaybeBoolExpression
   -- annotations
   ,annotateAst
   ,annotateAstEnv
   ,annotateExpression
   ,annotateAstsEnv
   ,annotateAstEnvEnv
}

{
import Data.Maybe
import Data.List
import Debug.Trace
import Control.Monad.Error
import Control.Arrow
import Data.Either
import Control.Applicative
import Data.Generics

import Database.HsSqlPpp.AstInternals.TypeType
import Database.HsSqlPpp.AstInternals.TypeConversion
import Database.HsSqlPpp.AstInternals.TypeCheckingH
import Database.HsSqlPpp.AstInternals.AstAnnotation
import Database.HsSqlPpp.AstInternals.EnvironmentInternal
import Database.HsSqlPpp.AstInternals.DefaultTemplate1Environment
import Database.HsSqlPpp.Utils
}

{-
================================================================================

SQL top level statements

everything is chucked in here: dml, ddl, plpgsql statements

-}

DATA Statement

--queries

    | SelectStatement ann:Annotation ex:SelectExpression

-- dml

    --table targetcolumns insertdata(values or select statement) returning
    | Insert ann:Annotation
             table : String
             targetCols : StringList
             insData : SelectExpression
             returning : (Maybe SelectList)
    --tablename setitems where returning
    | Update ann:Annotation
             table : String
             assigns : SetClauseList
             whr : MaybeBoolExpression
             returning : (Maybe SelectList)
    --tablename, where, returning
    | Delete ann:Annotation
             table : String
             whr : MaybeBoolExpression
             returning : (Maybe SelectList)
    --tablename column names, from
    | Copy ann:Annotation
           table : String
           targetCols : StringList
           source : CopySource
    --represents inline data for copy statement
    | CopyData ann:Annotation insData : String
    | Truncate ann:Annotation
               tables: StringList
               restartIdentity : RestartIdentity
               cascade : Cascade

-- ddl

    | CreateTable ann:Annotation
                  name : String
                  atts : AttributeDefList
                  cons : ConstraintList
    | CreateTableAs ann:Annotation
                    name : String
                    expr : SelectExpression
    | CreateView ann:Annotation
                 name : String
                 expr : SelectExpression
    | CreateType ann:Annotation
                 name : String
                 atts : TypeAttributeDefList
    -- language name args rettype bodyquoteused body vol
    | CreateFunction ann:Annotation
                     lang : Language
                     name : String
                     params : ParamDefList
                     rettype : TypeName
                     bodyQuote : String
                     body : FnBody
                     vol : Volatility
    -- name type checkexpression
    | CreateDomain ann:Annotation
                   name : String
                   typ : TypeName
                   check : MaybeBoolExpression
    -- ifexists (name,argtypes)* cascadeorrestrict
    | DropFunction ann:Annotation
                   ifE : IfExists
                   sigs : StringStringListPairList
                   cascade : Cascade
    -- ifexists names cascadeorrestrict
    | DropSomething ann:Annotation
                    dropType : DropType
                    ifE : IfExists
                    names : StringList
                    cascade : Cascade
    | Assignment ann:Annotation
                 target : String
                 value : Expression
    | Return ann:Annotation
             value : (MaybeExpression)
    | ReturnNext ann:Annotation
                 expr : Expression
    | ReturnQuery ann:Annotation
                  sel : SelectExpression
    | Raise ann:Annotation
            level : RaiseType
            message : String
            args : ExpressionList
    | NullStatement ann:Annotation
    | Perform ann:Annotation
              expr : Expression
    | Execute ann:Annotation
              expr : Expression
    | ExecuteInto ann:Annotation
                  expr : Expression
                  targets : StringList
    | ForSelectStatement ann:Annotation
                         var : String
                         sel : SelectExpression
                         sts : StatementList
    | ForIntegerStatement ann:Annotation
                          var : String
                          from : Expression
                          to : Expression
                          sts : StatementList
    | WhileStatement ann:Annotation
                     expr : Expression
                     sts : StatementList
    | ContinueStatement ann:Annotation
    --variable, list of when parts, else part
    | CaseStatement ann:Annotation
                    val : Expression
                    cases : ExpressionListStatementListPairList
                    els : StatementList
    --list is
    --first if (condition, statements):elseifs(condition, statements)
    --last bit is else statements
    | If ann:Annotation
         cases : ExpressionStatementListPairList
         els : StatementList

-- =============================================================================

--Statement components

-- maybe this should be called relation valued expression?
DATA SelectExpression
    | Select ann:Annotation
             selDistinct : Distinct
             selSelectList : SelectList
             selTref : TableRefList
             selWhere : MaybeBoolExpression
             selGroupBy : ExpressionList
             selHaving : MaybeBoolExpression
             selOrderBy : ExpressionDirectionPairList
             selLimit : MaybeExpression
             selOffset : MaybeExpression
    | CombineSelect ann:Annotation
                    ctype : CombineType
                    sel1 : SelectExpression
                    sel2 : SelectExpression
    | Values ann:Annotation
             vll:ExpressionListList

TYPE TableRefList = [TableRef]
TYPE MaybeExpression = MAYBE Expression
TYPE MaybeBoolExpression = MAYBE Expression

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

DATA SetClause | SetClause ann:Annotation att:String val:Expression
               | RowSetClause ann:Annotation atts:StringList vals:ExpressionList

DATA TableRef | Tref ann:Annotation
                     tbl:String
              | TrefAlias ann:Annotation
                          tbl : String
                          alias : String
              | JoinedTref ann:Annotation
                           tbl : TableRef
                           nat : Natural
                           joinType : JoinType
                           tbl1 : TableRef
                           onExpr : OnExpr
              | SubTref ann:Annotation
                        sel : SelectExpression
                        alias : String
              | TrefFun ann:Annotation
                        fn:Expression
              | TrefFunAlias ann:Annotation
                             fn:Expression
                             alias:String

TYPE OnExpr = MAYBE JoinExpression

DATA JoinExpression | JoinOn ann:Annotation Expression
                    | JoinUsing ann:Annotation StringList

DATA JoinType | Inner | LeftOuter| RightOuter | FullOuter | Cross

-- select columns, into columns

DATA SelectList | SelectList ann:Annotation items:SelectItemList StringList

DATA SelectItem | SelExp ann:Annotation ex:Expression
                | SelectItem ann:Annotation ex:Expression name:String

DATA CopySource | CopyFilename String
                | Stdin

--name type default null constraint

DATA AttributeDef | AttributeDef ann:Annotation
                                 name : String
                                 typ : TypeName
                                 def: MaybeExpression
                                 cons : RowConstraintList

--Constraints which appear attached to an individual field

DATA RowConstraint | NullConstraint ann:Annotation
                   | NotNullConstraint ann:Annotation
                   | RowCheckConstraint ann:Annotation Expression
                   | RowUniqueConstraint ann:Annotation
                   | RowPrimaryKeyConstraint ann:Annotation
                   | RowReferenceConstraint ann:Annotation
                                            table : String
                                            att : (Maybe String)
                                            onUpdate : Cascade
                                            onDelete : Cascade

--constraints which appear on a separate row in the create table

DATA Constraint | UniqueConstraint ann:Annotation StringList
                | PrimaryKeyConstraint ann:Annotation StringList
                | CheckConstraint ann:Annotation Expression
                  -- sourcecols targettable targetcols ondelete onupdate
                | ReferenceConstraint ann:Annotation
                                      atts : StringList
                                      table : String
                                      tableAtts : StringList
                                      onUpdate : Cascade
                                      onDelete : Cascade

DATA TypeAttributeDef | TypeAttDef ann:Annotation
                                   name : String
                                   typ : TypeName

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)

DATA RaiseType | RNotice | RException | RError

DATA CombineType | Except | Union | Intersect | UnionAll

DATA Volatility | Volatile | Stable | Immutable

DATA Language | Sql | Plpgsql

DATA TypeName | SimpleTypeName ann:Annotation tn:String
              | PrecTypeName ann:Annotation tn:String prec:Integer
              | ArrayTypeName ann:Annotation typ:TypeName
              | SetOfTypeName ann:Annotation typ:TypeName

DATA DropType | Table
              | Domain
              | View
              | Type

DATA Cascade | Cascade | Restrict

DATA Direction | Asc | Desc

DATA Distinct | Distinct | Dupes

DATA Natural | Natural | Unnatural

DATA IfExists | Require | IfExists

DATA RestartIdentity | RestartIdentity | ContinueIdentity

{-
================================================================================

Expressions

Similarly to the statement type, all expressions are chucked into one
even though there are many restrictions on which expressions can
appear in different places.  Maybe this should be called scalar
expression?

-}
DATA Expression | IntegerLit ann:Annotation i:Integer
                | FloatLit ann:Annotation d:Double
                | StringLit ann:Annotation
                            quote : String
                            value : String
                | NullLit ann:Annotation
                | BooleanLit ann:Annotation b:Bool
                | PositionalArg ann:Annotation p:Integer
                | Cast ann:Annotation
                       expr:Expression
                       tn:TypeName
                | Identifier ann:Annotation
                             i:String
                | Case ann:Annotation
                       cases : CaseExpressionListExpressionPairList
                       els : MaybeExpression
                | CaseSimple ann:Annotation
                             value : Expression
                             cases : CaseExpressionListExpressionPairList
                             els : MaybeExpression
                | Exists ann:Annotation
                         sel : SelectExpression
                | FunCall ann:Annotation
                          funName:String
                          args:ExpressionList
                | InPredicate ann:Annotation
                              expr:Expression
                              i:Bool
                              list:InList
                  -- windowfn selectitem partitionby orderby orderbyasc?
                | WindowFn ann:Annotation
                           fn : Expression
                           partitionBy : ExpressionList
                           orderBy : ExpressionList
                           dir : Direction
                | ScalarSubQuery ann:Annotation
                                 sel : SelectExpression

DATA InList | InList ann:Annotation exprs : ExpressionList
            | InSelect ann:Annotation sel : SelectExpression


{-

list of expression flavours from postgresql with the equivalents in this ast
pg                                here
--                                ----
constant/literal                  integerlit, floatlit, unknownstringlit, nulllit, boollit
column reference                  identifier
positional parameter reference    positionalarg
subscripted expression            funcall
field selection expression        identifier
operator invocation               funcall
function call                     funcall
aggregate expression              funcall
window function call              windowfn
type cast                         cast
scalar subquery                   scalarsubquery
array constructor                 funcall
row constructor                   funall

Anything that is represented in the ast as some sort of name plus a
list of expressions as arguments is treated as the same type of node:
FunCall.

This includes
symbol operators
regular function calls
keyword operators e.g. and, like (ones which can be parsed as normal
  syntactic operators)
unusual syntax operators, e.g. between
unusual syntax function calls e.g. substring(x from 5 for 3)
arrayctors e.g. array[3,5,6]
rowctors e.g. ROW (2,4,6)
array subscripting

list of keyword operators (regular prefix, infix and postfix):
and, or, not
is null, is not null, isnull, notnull
is distinct from, is not distinct from
is true, is not true,is false, is not false, is unknown, is not unknown
like, not like, ilike, not ilike
similar to, not similar to
in, not in (don't include these here since the argument isn't always an expr)

unusual syntax operators and fn calls
between, not between, between symmetric
overlay, substring, trim
any, some, all

Most of unusual syntax forms and keywords operators are not yet
supported, so this is mainly a todo list.

Keyword operators are encoded with the function name as a ! followed
by a string
e.g.
operator 'and' -> FunCall "!and" ...
see keywordOperatorTypes value in AstUtils.lhs for the list of
currently supported keyword operators.

-}

-- some list nodes, not sure if all of these are needed as separately
-- named node types

TYPE ExpressionList = [Expression]
TYPE ExpressionListList = [ExpressionList]
TYPE StringList = [String]
TYPE SetClauseList = [SetClause]
TYPE AttributeDefList = [AttributeDef]
TYPE ConstraintList = [Constraint]
TYPE TypeAttributeDefList = [TypeAttributeDef]
TYPE ParamDefList = [ParamDef]
TYPE StringStringListPair = (String,StringList)
TYPE StringStringListPairList = [StringStringListPair]
TYPE ExpressionListStatementListPair = (ExpressionList,StatementList)
TYPE ExpressionListStatementListPairList = [ExpressionListStatementListPair]
TYPE ExpressionStatementListPair = (Expression, StatementList)
TYPE ExpressionStatementListPairList = [ExpressionStatementListPair]
TYPE VarDefList = [VarDef]
TYPE SelectItemList = [SelectItem]
TYPE RowConstraintList = [RowConstraint]
TYPE CaseExpressionListExpressionPair = (CaseExpressionList,Expression)
TYPE CaseExpressionList = [Expression]
TYPE CaseExpressionListExpressionPairList = [CaseExpressionListExpressionPair]
TYPE StatementList = [Statement]
TYPE ExpressionDirectionPair = (Expression,Direction)
TYPE ExpressionDirectionPairList = [ExpressionDirectionPair]

-- Add a root data type so we can put initial values for inherited
-- attributes in the section which defines and uses those attributes
-- rather than in the sem_ calls

DATA Root | Root statements:StatementList
DERIVING Root: Show

-- use an expression root also to support type checking,
-- etc., individual expressions

DATA ExpressionRoot | ExpressionRoot expr:Expression
DERIVING ExpressionRoot: Show

{-
================================================================================

=some basic bookkeeping

attributes which every node has
-}

SET AllNodes = Statement SelectExpression FnBody SetClause TableRef
               JoinExpression JoinType
               SelectList SelectItem CopySource AttributeDef RowConstraint
               Constraint TypeAttributeDef ParamDef VarDef RaiseType
               CombineType Volatility Language TypeName DropType Cascade
               Direction Distinct Natural IfExists RestartIdentity
               Expression InList MaybeExpression MaybeBoolExpression
               ExpressionList ExpressionListList StringList SetClauseList
               AttributeDefList ConstraintList TypeAttributeDefList
               ParamDefList StringStringListPair StringStringListPairList
               StatementList ExpressionListStatementListPair
               ExpressionListStatementListPairList ExpressionStatementListPair
               ExpressionStatementListPairList VarDefList SelectItemList
               RowConstraintList CaseExpressionListExpressionPair
               CaseExpressionListExpressionPairList CaseExpressionList
               TableRefList TableRef OnExpr ExpressionDirectionPair
               ExpressionDirectionPairList

DERIVING AllNodes: Show,Eq,Typeable,Data


INCLUDE "TypeChecking.ag"

{-

================================================================================

used to use record syntax to try to insulate code from field changes,
and not have to write out loads of nothings and [] for simple selects,
but don't know how to create haskell named records from uuagc DATA
things

makeSelect :: Statement
makeSelect = Select Dupes (SelectList [SelExp (Identifier "*")] [])
                   Nothing Nothing [] Nothing [] Asc Nothing Nothing


================================================================================

= annotation functions

-}
{
-- | Takes an ast, and adds annotations, including types, type errors,
-- and statement info. Type checks against defaultEnv.
annotateAst :: StatementList -> StatementList
annotateAst = annotateAstEnv defaultTemplate1Environment


-- | As annotateAst but you supply an environment to check
-- against. See Environment module for how to read an Environment from
-- an existing database so you can type check against it.
annotateAstEnv :: Environment -> StatementList -> StatementList
annotateAstEnv env sts =
    let t = sem_Root (Root sts)
        ta = wrap_Root t Inh_Root {env_Inh_Root = env}
        tl = annotatedTree_Syn_Root ta
   in case tl of
         Root r -> r

-- | Type check multiple asts, allowing type checking references in later
--   files to definitions in earlier files.
annotateAstsEnv :: Environment -> [StatementList] -> [StatementList]
annotateAstsEnv env sts =
    annInt env sts []
    where
      annInt e (s:ss) ress =
          let (e1,res) = annotateAstEnvEnv e s
          in annInt e1 ss (res:ress)
      annInt _ [] ress = reverse ress

-- | Type check an ast, and return the resultant Environment as well
--   as the annotated ast.
annotateAstEnvEnv :: Environment -> StatementList -> (Environment,StatementList)
annotateAstEnvEnv env sts =
    let t = sem_Root (Root sts)
        ta = wrap_Root t Inh_Root {env_Inh_Root = env}
        tl = annotatedTree_Syn_Root ta
        env1 = producedEnv_Syn_Root ta
   in case tl of
         Root r -> (env1,r)

-- | Testing utility, mainly used to check an expression for type errors
-- or to get its type.
annotateExpression :: Environment -> Expression -> Expression
annotateExpression env ex =
    let t = sem_ExpressionRoot (ExpressionRoot ex)
        rt = (annotatedTree_Syn_ExpressionRoot
              (wrap_ExpressionRoot t Inh_ExpressionRoot {env_Inh_ExpressionRoot = env}))
    in case rt of
         ExpressionRoot e -> e

}

{-

Future plans:

Investigate how much mileage can get out of making these nodes the
parse tree nodes, and using a separate ast. Hinges on how much extra
value can get from making the types more restrictive for the ast nodes
compared to the parse tree. Starting to think this won't be worth it.

Would like to turn this back into regular Haskell file, maybe could
use AspectAG instead of uuagc to make this happen?


-}