hssqlppp-0.1.0: Database/HsSqlPpp/AstInternals/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 (..)
,TableAlias(..)
,JoinExpression (..)
,JoinType (..)
,SelectList (..)
,SelectItem (..)
,CopySource (..)
,AttributeDef (..)
,RowConstraint (..)
,AlterTableAction(..)
,Constraint (..)
,TypeAttributeDef (..)
,ParamDef (..)
,VarDef (..)
,RaiseType (..)
,CombineType (..)
,Volatility (..)
,Language (..)
,TypeName (..)
,DropType (..)
,Cascade (..)
,Direction (..)
,Distinct (..)
,Natural (..)
,IfExists (..)
,RestartIdentity (..)
,Expression (..)
,FrameClause(..)
,InList (..)
,LiftFlavour(..)
,TriggerWhen(..)
,TriggerEvent(..)
,TriggerFire(..)
,StatementList
,ExpressionListStatementListPairList
,ExpressionListStatementListPair
,ExpressionList
,StringList
,ParamDefList
,AttributeDefList
,ConstraintList
,TypeAttributeDefList
,TypeNameList
,StringTypeNameListPair
,StringTypeNameListPairList
,ExpressionStatementListPairList
,SetClauseList
,CaseExpressionListExpressionPairList
,MaybeExpression
,TableRefList
,ExpressionListList
,SelectItemList
,OnExpr
,RowConstraintList
,VarDefList
,ExpressionStatementListPair
,CaseExpressionListExpressionPair
,CaseExpressionList
,ExpressionDirectionPair
,ExpressionDirectionPairList
,MaybeBoolExpression
,MaybeSelectList
,SetValue(..)
-- typechecking
,typeCheck
,typeCheckPS
,typeCheckExpression
}
{
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 Data.Char
import Database.HsSqlPpp.AstInternals.TypeType
import Database.HsSqlPpp.AstInternals.TypeChecking.TypeConversion
import Database.HsSqlPpp.AstInternals.TypeChecking.ErrorUtils
import Database.HsSqlPpp.AstInternals.AstAnnotation
import Database.HsSqlPpp.AstInternals.Environment.EnvironmentInternal
import Database.HsSqlPpp.AstInternals.Environment.LocalIdentifierBindings
import Database.HsSqlPpp.AstInternals.Environment.DefaultTemplate1Environment
import Database.HsSqlPpp.Utils
import Data.Generics.PlateData
}
{-
================================================================================
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 : MaybeSelectList
--tablename setitems where returning
| Update ann:Annotation
table : String
assigns : SetClauseList
whr : MaybeBoolExpression
returning : MaybeSelectList
--tablename, where, returning
| Delete ann:Annotation
table : String
whr : MaybeBoolExpression
returning : MaybeSelectList
--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
| AlterTable ann:Annotation
name : String
actions : {[AlterTableAction]}
| CreateSequence ann:Annotation
name:String
incr:Integer
min:Integer
max:Integer
start:Integer
cache:Integer
| AlterSequence ann:Annotation
name:String
ownedBy: String
| 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
name : String
params : ParamDefList
rettype : TypeName
lang : Language
bodyQuote : String
body : FnBody
vol : Volatility
-- name type checkexpression
| CreateDomain ann:Annotation
name : String
typ : TypeName
checkName: String
check : MaybeBoolExpression
| CreateLanguage ann:Annotation
name:String
| CreateTrigger ann:Annotation
name:String
wh : TriggerWhen
events: {[TriggerEvent]}
tbl : String
firing : TriggerFire
fnName : String
fnArgs : {[Expression]}
-- ifexists (name,argtypes)* cascadeorrestrict
| DropFunction ann:Annotation
ifE : IfExists
sigs : StringTypeNameListPairList
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
--misc
| Set ann:Annotation name:String values:{[SetValue]}
| Notify ann:Annotation name:String
-- =============================================================================
--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
alias : TableAlias
| JoinedTref ann:Annotation
tbl : TableRef
nat : Natural
joinType : JoinType
tbl1 : TableRef
onExpr : OnExpr
alias : TableAlias
| SubTref ann:Annotation
sel : SelectExpression
alias : TableAlias
| TrefFun ann:Annotation
fn:Expression
alias : TableAlias
DATA TableAlias | NoAlias
| TableAlias alias:String
| FullAlias alias:String cols:{[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 into:StringList
TYPE MaybeSelectList = MAYBE SelectList
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 name:String
| NotNullConstraint ann:Annotation name:String
| RowCheckConstraint ann:Annotation name:String Expression
| RowUniqueConstraint ann:Annotation name:String
| RowPrimaryKeyConstraint ann:Annotation name:String
| RowReferenceConstraint ann:Annotation name:String
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 name:String StringList
| PrimaryKeyConstraint ann:Annotation name:String StringList
| CheckConstraint ann:Annotation name:String Expression
-- sourcecols targettable targetcols ondelete onupdate
| ReferenceConstraint ann:Annotation
name:String
atts : StringList
table : String
tableAtts : StringList
onUpdate : Cascade
onDelete : Cascade
DATA TypeAttributeDef | TypeAttDef ann:Annotation
name : String
typ : TypeName
DATA AlterTableAction | AlterColumnDefault ann:Annotation
nm : String
def : Expression
| AddConstraint ann:Annotation
con: Constraint
DATA SetValue
| SetStr ann:Annotation String
| SetId ann:Annotation String
| SetNum ann:Annotation Double
DATA TriggerWhen | TriggerBefore | TriggerAfter
DATA TriggerEvent | TInsert| TUpdate | TDelete
DATA TriggerFire | EachRow | EachStatement
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
| Placeholder ann:Annotation -- represents a '?'
| 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 ann:Annotation
fn : Expression
partitionBy : ExpressionList
orderBy : ExpressionList
dir : Direction
frm : FrameClause
| ScalarSubQuery ann:Annotation
sel : SelectExpression
| LiftOperator ann:Annotation
oper:String
flav:LiftFlavour
args:ExpressionList
DATA LiftFlavour | LiftAny | LiftAll
--todo: use liftoperator to implement inlist?
DATA InList | InList ann:Annotation exprs : ExpressionList
| InSelect ann:Annotation sel : SelectExpression
DATA FrameClause | FrameUnboundedPreceding
| FrameUnboundedFull
| FrameRowsUnboundedPreceding
{-
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 TypeNameList = [TypeName]
TYPE StringTypeNameListPair = (String, TypeNameList)
TYPE StringTypeNameListPairList = [StringTypeNameListPair]
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 TypeNameList StringTypeNameListPair
StringTypeNameListPairList
StatementList ExpressionListStatementListPair
ExpressionListStatementListPairList ExpressionStatementListPair
ExpressionStatementListPairList VarDefList SelectItemList
RowConstraintList CaseExpressionListExpressionPair
CaseExpressionListExpressionPairList CaseExpressionList
TableRefList TableRef OnExpr LiftFlavour MaybeSelectList
SetValue TableAlias FrameClause AlterTableAction
TriggerWhen TriggerEvent TriggerFire ExpressionDirectionPair
ExpressionDirectionPairList
DERIVING AllNodes: Show,Eq,Typeable,Data
INCLUDE "TypeChecking/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
-}
{
{-
-- | Type check multiple asts, allowing type checking references in
-- later files to definitions in earlier files. This is probably
-- more straightforward if you parse the files then concatenate the
-- statementlists together before type checking rather than using
-- this function
typeCheckMany :: Environment -> [StatementList] -> [StatementList]
typeCheckMany env sts =
annInt env sts []
where
annInt e (s:ss) ress =
let (e1,res) = typeCheck e s
in annInt e1 ss (res:ress)
annInt _ [] ress = reverse ress
-}
-- | Takes an ast, checks against catalog passed, and adds
-- annotations, including types, type errors, and statement info.
-- Returns the updated catalog as well as the annotated ast.
typeCheck :: Environment -> StatementList -> (Environment,StatementList)
typeCheck env sts =
let t = sem_Root (Root (fixupImplicitJoins sts))
ta = wrap_Root t Inh_Root {env_Inh_Root = env
,lib_Inh_Root = emptyBindings}
tl = annotatedTree_Syn_Root ta
env1 = producedEnv_Syn_Root ta
in case tl of
Root r -> (env1,r)
-- | Unfinished version of type check which can type check an
-- individual statement with ? or positional arg placeholders in
-- it. Will error if the statement isn't select, update, insert or
-- delete. For use in type checking embedded parameterized
-- statements. Does all typechecking and annotation that the regular
-- typecheck does.
typeCheckPS :: Environment -> Statement -> Either String Statement
typeCheckPS env st =
case st of
SelectStatement _ _ -> tc
Insert _ _ _ _ _ -> tc
Update _ _ _ _ _ -> tc
Delete _ _ _ _ -> tc
_ -> Left "requires select, update, insert or delete statement"
where
tc = let t = sem_Root (Root (fixupImplicitJoins [st]))
ta = wrap_Root t Inh_Root {env_Inh_Root = env
,lib_Inh_Root = emptyBindings}
tl = annotatedTree_Syn_Root ta
env1 = producedEnv_Syn_Root ta
in case tl of
Root [st1] -> Right st1
_ -> error "impossible happened in typeCheckPS!"
-- | Testing utility, mainly used to check an expression for type errors
-- or to get its type.
typeCheckExpression :: Environment -> Expression -> Expression
typeCheckExpression env ex =
let t = sem_ExpressionRoot (ExpressionRoot (fixupImplicitJoins ex))
rt = (annotatedTree_Syn_ExpressionRoot
(wrap_ExpressionRoot t Inh_ExpressionRoot {env_Inh_ExpressionRoot = env
,lib_Inh_ExpressionRoot = emptyBindings}))
in case rt of
ExpressionRoot e -> e
{-
bit of a hack, to avoid rewriting the tableref type checking to be
able to do implicit joins, we just convert them in to the equivalent
explicit join
-}
fixupImplicitJoins :: Data a => a -> a
fixupImplicitJoins =
transformBi $ \x ->
case x of
-- alter asts to change implicit joins into explicit joins
Select an dis sl trs@(_:_:_) whr grp hav ord lim off
-> Select an dis sl [convTrefs trs] whr grp hav ord lim off
x1 -> x1
where
convTrefs (tr:tr1:trs) = JoinedTref [] tr Unnatural Cross (convTrefs (tr1:trs)) Nothing NoAlias
convTrefs (tr:[]) = tr
convTrefs _ = error "failed doing implicit join fixup hack"
}
{-
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?
-}