{- 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 pretty printer. = compiling use uuagc -dcfws AstInternal.ag to generate a new AstInternal.hs from this file (install uuagc with cabal install uuagc ) -} MODULE {Database.HsSqlPpp.TypeChecking.AstInternal} { --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 ,Where ,StringStringListPairList ,StringStringListPair ,ExpressionStatementListPairList ,SetClauseList ,CaseExpressionListExpressionPairList ,MaybeExpression ,MTableRef ,ExpressionListList ,SelectItemList ,OnExpr ,RowConstraintList ,VarDefList ,ExpressionStatementListPair ,MExpression ,CaseExpressionListExpressionPair ,CaseExpressionList -- annotations ,annotateAst ,annotateAstScope ,annotateExpression } { import Data.Maybe import Data.List import Debug.Trace import Control.Monad.Error import Control.Arrow import Data.Either import Control.Applicative import Database.HsSqlPpp.TypeChecking.TypeType import Database.HsSqlPpp.TypeChecking.AstUtils import Database.HsSqlPpp.TypeChecking.TypeConversion import Database.HsSqlPpp.TypeChecking.TypeCheckingH import Database.HsSqlPpp.TypeChecking.Scope import Database.HsSqlPpp.TypeChecking.ScopeData import Database.HsSqlPpp.TypeChecking.AstAnnotation } {- ================================================================================ 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 : Where returning : (Maybe SelectList) --tablename, where, returning | Delete ann:Annotation table : String whr : Where 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 : (Maybe Expression) -- 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 : (Maybe Expression) | 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 : MTableRef selWhere : Where selGroupBy : ExpressionList selHaving : MExpression selOrderBy : ExpressionList selDir : Direction selLimit : MExpression selOffset : MExpression | CombineSelect ann:Annotation ctype : CombineType sel1 : SelectExpression sel2 : SelectExpression | Values ann:Annotation vll:ExpressionListList TYPE MTableRef = MAYBE TableRef TYPE Where = MAYBE Expression TYPE MExpression = MAYBE Expression DATA FnBody | SqlFnBody sts : StatementList | PlpgsqlFnBody VarDefList sts : StatementList DATA SetClause | SetClause att:String val:Expression | RowSetClause 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 Expression | JoinUsing StringList DATA JoinType | Inner | LeftOuter| RightOuter | FullOuter | Cross -- select columns, into columns DATA SelectList | SelectList items:SelectItemList StringList DATA SelectItem | SelExp ex:Expression | SelectItem ex:Expression name:String DATA CopySource | CopyFilename String | Stdin --name type default null constraint DATA AttributeDef | AttributeDef name : String typ : TypeName check : (Maybe Expression) cons : RowConstraintList --Constraints which appear attached to an individual field DATA RowConstraint | NullConstraint | NotNullConstraint | RowCheckConstraint Expression | RowUniqueConstraint | RowPrimaryKeyConstraint | RowReferenceConstraint table : String att : (Maybe String) onUpdate : Cascade onDelete : Cascade --constraints which appear on a separate row in the create table DATA Constraint | UniqueConstraint StringList | PrimaryKeyConstraint StringList | CheckConstraint Expression -- sourcecols targettable targetcols ondelete onupdate | ReferenceConstraint atts : StringList table : String tableAtts : StringList onUpdate : Cascade onDelete : Cascade DATA TypeAttributeDef | TypeAttDef name : String typ : TypeName DATA ParamDef | ParamDef name:String typ:TypeName | ParamDefTp typ:TypeName DATA VarDef | VarDef 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 tn:String | PrecTypeName tn:String prec:Integer | ArrayTypeName typ:TypeName | SetOfTypeName 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 exprs : ExpressionList | InSelect sel : SelectExpression TYPE MaybeExpression = MAYBE Expression {- 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] -- 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 ExpressionList ExpressionListList StringList SetClauseList AttributeDefList ConstraintList TypeAttributeDefList ParamDefList StringStringListPair StringStringListPairList StatementList ExpressionListStatementListPair ExpressionListStatementListPairList ExpressionStatementListPair ExpressionStatementListPairList VarDefList SelectItemList RowConstraintList CaseExpressionListExpressionPair CaseExpressionListExpressionPairList CaseExpressionList MTableRef TableRef OnExpr Where MExpression DERIVING AllNodes: Show,Eq 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 defaultScope. annotateAst :: StatementList -> StatementList annotateAst = annotateAstScope defaultScope -- | As annotateAst but you supply an additional scope to add to the -- defaultScope to type check against. See Scope module for how to -- read a scope from an existing database so you can type check -- against it. annotateAstScope :: Scope -> StatementList -> StatementList annotateAstScope scope sts = let t = sem_Root (Root sts) ta = wrap_Root t Inh_Root {scope_Inh_Root = combineScopes defaultScope scope} tl = annotatedTree_Syn_Root ta in case tl of Root r -> r -- | Testing utility, mainly used to check an expression for type errors -- or to get its type. annotateExpression :: Scope -> Expression -> Expression annotateExpression scope ex = let t = sem_ExpressionRoot (ExpressionRoot ex) rt = (annotatedTree_Syn_ExpressionRoot (wrap_ExpressionRoot t Inh_ExpressionRoot {scope_Inh_ExpressionRoot = combineScopes defaultScope scope})) in case rt of ExpressionRoot e -> e {- ================================================================================ = instances for Annotated. Hopefully, some sort of SYB approach can be used to autogenerate these in the future. It is imperative that this or template haskell or something similar be used because doing it by hand guarantees some bits will be missed. Stupidity watch update: use attributes to do this. Doh. -} instance Annotated Statement where ann a = case a of SelectStatement ann _ -> ann Insert ann _ _ _ _ -> ann Update ann _ _ _ _ -> ann Delete ann _ _ _ -> ann Copy ann _ _ _ -> ann CopyData ann _ -> ann Truncate ann _ _ _ -> ann CreateTable ann _ _ _ -> ann CreateTableAs ann _ _ -> ann CreateView ann _ _ -> ann CreateType ann _ _ -> ann CreateFunction ann _ _ _ _ _ _ _ -> ann CreateDomain ann _ _ _ -> ann DropFunction ann _ _ _ -> ann DropSomething ann _ _ _ _ -> ann Assignment ann _ _ -> ann Return ann _ -> ann ReturnNext ann _ -> ann ReturnQuery ann _ -> ann Raise ann _ _ _ -> ann NullStatement ann -> ann Perform ann _ -> ann Execute ann _ -> ann ExecuteInto ann _ _ -> ann ForSelectStatement ann _ _ _ -> ann ForIntegerStatement ann _ _ _ _ -> ann WhileStatement ann _ _ -> ann ContinueStatement ann -> ann CaseStatement ann _ _ _ -> ann If ann _ _ -> ann setAnn st a = case st of SelectStatement _ ex -> SelectStatement a ex Insert _ tbl cols ins ret -> Insert a tbl cols ins ret Update _ tbl as whr ret -> Update a tbl as whr ret Delete _ tbl whr ret -> Delete a tbl whr ret Copy _ tbl cols src -> Copy a tbl cols src CopyData _ i -> CopyData a i Truncate _ tbls ri cs -> Truncate a tbls ri cs CreateTable _ name atts cons -> CreateTable a name atts cons CreateTableAs _ name ex -> CreateTableAs a name ex CreateView _ name expr -> CreateView a name expr CreateType _ name atts -> CreateType a name atts CreateFunction _ lang name params rettype bodyQuote body vol -> CreateFunction a lang name params rettype bodyQuote body vol CreateDomain _ name typ check -> CreateDomain a name typ check DropFunction _ i s cs -> DropFunction a i s cs DropSomething _ dt i nms cs -> DropSomething a dt i nms cs Assignment _ tgt val -> Assignment a tgt val Return _ v -> Return a v ReturnNext _ ex -> ReturnNext a ex ReturnQuery _ sel -> ReturnQuery a sel Raise _ l m args -> Raise a l m args NullStatement _ -> NullStatement a Perform _ expr -> Perform a expr Execute _ expr -> Execute a expr ExecuteInto _ expr tgts -> ExecuteInto a expr tgts ForSelectStatement _ var sel sts -> ForSelectStatement a var sel sts ForIntegerStatement _ var from to sts -> ForIntegerStatement a var from to sts WhileStatement _ expr sts -> WhileStatement a expr sts ContinueStatement _ -> ContinueStatement a CaseStatement _ val cases els -> CaseStatement a val cases els If _ cases els -> If a cases els changeAnnRecurse f st = case st of SelectStatement a ex -> SelectStatement (f a) ex Insert a tbl cols ins ret -> Insert (f a) tbl cols ins ret Update a tbl as whr ret -> Update (f a) tbl as whr ret Delete a tbl whr ret -> Delete (f a) tbl whr ret Copy a tbl cols src -> Copy (f a) tbl cols src CopyData a i -> CopyData (f a) i Truncate a tbls ri cs -> Truncate (f a) tbls ri cs CreateTable a name atts cons -> CreateTable (f a) name atts cons CreateTableAs a name ex -> CreateTableAs (f a) name ex CreateView a name expr -> CreateView (f a) name expr CreateType a name atts -> CreateType (f a) name atts CreateFunction a lang name params rettype bodyQuote body vol -> CreateFunction (f a) lang name params rettype bodyQuote doBody vol where doBody = case body of SqlFnBody sts -> SqlFnBody $ cars f sts PlpgsqlFnBody vars sts -> PlpgsqlFnBody vars $ cars f sts CreateDomain a name typ check -> CreateDomain (f a) name typ check DropFunction a i s cs -> DropFunction (f a) i s cs DropSomething a dt i nms cs -> DropSomething (f a) dt i nms cs Assignment a tgt val -> Assignment (f a) tgt val Return a v -> Return (f a) v ReturnNext a ex -> ReturnNext (f a) ex ReturnQuery a sel -> ReturnQuery (f a) sel Raise a l m args -> Raise (f a) l m args NullStatement a -> NullStatement (f a) Perform a expr -> Perform (f a) expr Execute a expr -> Execute (f a) expr ExecuteInto a expr tgts -> ExecuteInto (f a) expr tgts ForSelectStatement a var sel sts -> ForSelectStatement (f a) var sel $ cars f sts ForIntegerStatement a var from to sts -> ForIntegerStatement (f a) var from to $ cars f sts WhileStatement a expr sts -> WhileStatement (f a) expr $ cars f sts ContinueStatement a -> ContinueStatement (f a) CaseStatement a val cases els -> CaseStatement (f a) val doCases $ cars f els where doCases = map (second (cars f)) cases If a cases els -> If (f a) doCases $ cars f els where doCases = map (second (cars f)) cases --where -- doCases cs = map (\(ex,sts) -> (ex,cars f sts)) cs getAnnChildren st = case st of SelectStatement _ ex -> gacse ex Insert _ _ _ ins _ -> gacse ins Update _ _ as whr _ -> mp (gacscl as) ++ gacme whr Delete _ _ whr _ -> gacme whr --Copy _ _ _ _ -> [] --CopyData _ _ -> [] --Truncate _ _ _ _ -> [] --CreateTable _ _ _ _ -> [] --CreateTableAs _ _ _ -> [] CreateView _ _ expr -> gacse expr --CreateType _ _ _ -> [] --CreateFunction a lang name params rettype bodyQuote body vol -> CreateFunction _ _ _ _ _ _ body _ -> case body of SqlFnBody sts -> mp sts PlpgsqlFnBody _ sts -> mp sts --CreateDomain _ _ _ _ -> [] --DropFunction _ _ _ _ -> [] --DropSomething _ _ _ _ _ -> [] --Assignment _ _ _ -> [] --Return a v -> Return (f a) v --ReturnNext a ex -> ReturnNext (f a) ex --ReturnQuery a sel -> ReturnQuery (f a) sel --Raise a l m args -> Raise (f a) l m args --NullStatement a -> NullStatement (f a) --Perform a expr -> Perform (f a) expr --Execute a expr -> Execute (f a) expr --ExecuteInto a expr tgts -> ExecuteInto (f a) expr tgts ForSelectStatement _ _ sel sts -> gacse sel ++ mp sts ForIntegerStatement _ _ _ _ sts -> mp sts WhileStatement _ expr sts -> pack expr : mp sts --ContinueStatement a -> ContinueStatement (f a) CaseStatement _ val cases els -> pack val : mp (doCases cases) ++ mp els If _ cases els -> mp $ doCases cases ++ els _ -> [] where doCases = concatMap snd --gacse :: Annotated a => SelectExpression -> [a] gacse se = [pack se] gacscl :: Annotated a => SetClauseList -> [a] gacscl _ = [] --gacme :: Annotated a => Maybe Expression -> [a] gacme e = case e of Nothing -> [] Just e1 -> [pack e1] mp = map pack cars = map . changeAnnRecurse instance Annotated Expression where ann a = case a of IntegerLit ann _ -> ann FloatLit ann _ -> ann StringLit ann _ _ -> ann NullLit ann -> ann BooleanLit ann _ -> ann PositionalArg ann _ -> ann Cast ann _ _ -> ann Identifier ann _ -> ann Case ann _ _ -> ann CaseSimple ann _ _ _ -> ann Exists ann _ -> ann FunCall ann _ _ -> ann InPredicate ann _ _ _ -> ann WindowFn ann _ _ _ _ -> ann ScalarSubQuery ann _ -> ann setAnn ex a = case ex of IntegerLit _ i -> IntegerLit a i FloatLit _ d -> FloatLit a d StringLit _ q v -> StringLit a q v NullLit _ -> NullLit a BooleanLit _ b -> BooleanLit a b PositionalArg _ p -> PositionalArg a p Cast _ expr tn -> Cast a expr tn Identifier _ i -> Identifier a i Case _ cases els -> Case a cases els CaseSimple _ val cases els -> CaseSimple a val cases els Exists _ sel -> Exists a sel FunCall _ funName args -> FunCall a funName args InPredicate _ expr i list -> InPredicate a expr i list WindowFn _ fn par ord dir -> WindowFn a fn par ord dir ScalarSubQuery _ sel -> ScalarSubQuery a sel changeAnnRecurse f ex = case ex of IntegerLit a i -> IntegerLit (f a) i FloatLit a d -> FloatLit (f a) d StringLit a q v -> StringLit (f a) q v NullLit a -> NullLit a BooleanLit a b -> BooleanLit (f a) b PositionalArg a p -> PositionalArg (f a) p Cast a expr tn -> Cast (f a) (changeAnnRecurse f expr) tn Identifier a i -> Identifier (f a) i Case a cases els -> Case (f a) cases els CaseSimple a val cases els -> CaseSimple (f a) val cases els Exists a sel -> Exists (f a) sel FunCall a funName args -> FunCall (f a) funName args InPredicate a expr i list -> InPredicate (f a) expr i list WindowFn a fn par ord dir -> WindowFn (f a) fn par ord dir ScalarSubQuery a sel -> ScalarSubQuery (f a) sel getAnnChildren ex = case ex of Cast _ expr _ -> mp [expr] Case _ cases els -> gacce cases els CaseSimple _ val cases els -> pack val : gacce cases els Exists a sel -> [pack sel] FunCall _ _ args -> mp args --InPredicate a expr i list -> InPredicate (f a) expr i list --WindowFn a fn par ord dir -> WindowFn (f a) fn par ord dir --ScalarSubQuery a sel -> ScalarSubQuery (f a) sel _ -> [] where gacme e = case e of Nothing -> [] Just e1 -> [pack e1] gacce cs el = mp (concatMap (\(el,e) -> el ++ [e]) cs) ++ gacme el mp = map pack instance Annotated SelectExpression where ann a = case a of Select ann _ _ _ _ _ _ _ _ _ _ -> ann CombineSelect ann _ _ _ -> ann Values ann _ -> ann setAnn ex a = case ex of Select _ dis sl tref whr grp hav ord dir lim off -> Select a dis sl tref whr grp hav ord dir lim off CombineSelect _ ctype sel1 sel2 -> CombineSelect a ctype sel1 sel2 Values _ vll -> Values a vll changeAnnRecurse f ex = case ex of Select a dis sl tref whr grp hav ord dir lim off -> Select (f a) dis sl tref whr grp hav ord dir lim off CombineSelect a ctype sel1 sel2 -> CombineSelect (f a) ctype (changeAnnRecurse f sel1) (changeAnnRecurse f sel2) Values a vll -> Values (f a) vll getAnnChildren ex = case ex of Select a dis sl tref whr grp hav ord dir lim off -> doSl ++ map pack (maybeToList tref) ++ doME whr ++ mp grp ++ doME hav ++ mp ord ++ doME lim ++ doME off where doSl = let SelectList x _ = sl ses = map (\s -> case s of SelExp se -> se SelectItem se _ -> se) x in map pack ses doME me = case me of Nothing -> [] Just e -> [pack e] CombineSelect _ _ sel1 sel2 -> [pack sel1,pack sel2] Values _ vll -> mp $ concat vll where mp = map pack instance Annotated TableRef where ann a = case a of Tref ann _ -> ann TrefAlias ann _ _ -> ann JoinedTref ann _ _ _ _ _ -> ann SubTref ann _ _ -> ann TrefFun ann _ -> ann TrefFunAlias ann _ _ -> ann setAnn ex a = case ex of Tref _ tbl -> Tref a tbl TrefAlias _ tbl alias -> TrefAlias a tbl alias JoinedTref _ tbl nat joinType tbl1 onExpr -> JoinedTref a tbl nat joinType tbl1 onExpr SubTref _ sel alias -> SubTref a sel alias TrefFun _ fn -> TrefFun a fn TrefFunAlias _ fn alias -> TrefFunAlias a fn alias changeAnnRecurse f ex = case ex of Tref a tbl -> Tref (f a) tbl TrefAlias a tbl alias -> TrefAlias (f a) tbl alias JoinedTref a tbl nat joinType tbl1 onExpr -> JoinedTref (f a) (changeAnnRecurse f tbl) nat joinType (changeAnnRecurse f tbl1) onExpr SubTref a sel alias -> SubTref (f a) (changeAnnRecurse f sel) alias TrefFun a fn -> TrefFun (f a) (changeAnnRecurse f fn) TrefFunAlias a fn alias -> TrefFunAlias (f a) (changeAnnRecurse f fn) alias getAnnChildren ex = case ex of Tref a tbl -> [] TrefAlias a tbl alias -> [] JoinedTref _ tbl _ _ tbl1 onExpr -> getAnnChildren tbl ++ getAnnChildren tbl1 SubTref a sel alias -> getAnnChildren sel TrefFun a fn -> getAnnChildren fn TrefFunAlias a fn alias -> getAnnChildren fn } {- 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? -}