module Plsl_ast where
{-
Copyright (c) 2008, Larry Layland
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
* Neither the name of the plsl_lint nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
import Data.List
import Data.Char
import Maybe
data Program
= ProgramStat Stat
| ProgramDec Dec
deriving (Eq)
instance Show Program where
show (ProgramStat s) = show s
show (ProgramDec d) = show d
type BlockName = Label
type Context = String
type BulkIntoClause = BasicSqlClause
type IntoClause = BasicSqlClause
type WhereClause = BasicSqlClause
type GroupByClause = BasicSqlClause
type HavingClause = WhereClause
type OrderByClause = BasicSqlClause
type ReturnClause = BasicSqlClause
type SetClause = BasicSqlClause
type InsertColClause = BasicSqlClause
type InsertValClause = BasicSqlClause
type Distinct = String
type CurrentOf = (Maybe Ident)
data BasicSqlClause
= BasicSqlClause (Maybe [SqlExp])
deriving (Eq)
data FromClause
= FromClause [SqlExp]
deriving (Eq, Show)
data WithClause
= WithClause [(Ident, SqlExp)]
deriving (Eq)
data SetOp
= SetOp String Select OrderByClause
deriving (Eq, Show)
data Select
= Select Distinct [SqlExp]
BulkIntoClause IntoClause FromClause WhereClause GroupByClause HavingClause OrderByClause ReturnClause WithClause
[SetOp]
deriving (Eq)
data FormalParam
= FormalParam Ident String String PlType Nullable AExp
deriving (Eq)
type Constant = Bool
type Nullable = Bool
type ReturnType = (Maybe Ident)
data Dec
= VarDec Ident String PlType Constant Nullable AExp
| ProcedureSpecDec Label (Seq FormalParam) ReturnType String
| DecWithBody Dec BlockStat
| DecWithSelect Dec Select
| Pragma Ident [Char]
| RecordDec Ident (Seq Dec)
| TableDec Ident PlType (Maybe PlType) Nullable
| VarrayDec Ident PlType AExp Nullable
deriving (Eq)
data Ident
= NIdent String Context
| QIdent String Context
| QualIdent [Ident] Context
instance Eq Ident where
(==) (NIdent a _) (NIdent b _) = (map toUpper a) == (map toUpper b)
(==) (QIdent a _) (QIdent b _) = a==b
(==) (QualIdent a _) (QualIdent b _) = a==b
(==) _ _ = False
data AExp
= Var Ident
| IntLit Integer
| StringLit String
| AOp String AExp AExp
| AUnOp String AExp
| NullLiteral
| DummyAExp Context
| BUnOp String AExp
| BoolLit Bool
| NullBoolLit
| BOp String AExp AExp
| RelOp String AExp AExp
| RelUnOp String AExp
| AExpList String [AExp]
| FunctionCall ProcCall
| NestedSelect Select
| BetweenExpr AExp AExp AExp
deriving (Eq)
data ProcCall
= ProcCall Ident (Seq ActualParam)
deriving (Eq)
data Analytic
= Analytic BasicSqlClause BasicSqlClause
data ActualParam
= UnNamedParam AExp
| NamedParam Ident AExp
deriving (Eq)
data SqlExp
= UnNamedSqlExp AExp
| NamedSqlExp Ident AExp
deriving (Eq)
data If' = If' AExp (Seq Stat)
deriving (Eq)
data CaseOf' = CaseOf' (Maybe AExp) (Seq Stat)
deriving (Eq)
data Handler = Handler [Ident] (Seq Stat)
deriving (Eq)
data Stat
-- = Assign Ident AExp
= Assign AExp AExp
| Exit AExp Label
| Goto Label
| ReturnStat
| ReturnValueStat AExp
| BlockWrap BlockName BlockStat
| NullStat
| RaiseStat (Maybe Ident)
| CommitStat (Maybe AExp) [String] (Maybe AExp) (Maybe AExp)
| RollbackStat (Maybe Ident) (Maybe AExp)
| SavepointStat Ident
| FetchStat Ident [Ident] AExp
| LockTableStat [Ident] [String] Bool
| CloseStat Ident
| SetTranStat String [String] (Maybe Ident) (Maybe AExp)
| ProcedureCall ProcCall
| OpenCurStat ProcCall
| DynOpenCurForStat Ident AExp
| OpenCurForStat Ident Select
| SelectStat Select
| ExecStat AExp
| UpdateStat FromClause WhereClause SetClause CurrentOf ReturnClause
| DeleteStat FromClause WhereClause CurrentOf ReturnClause
| InsertStat Ident InsertColClause InsertValClause ReturnClause
| InsertSelectStat Ident InsertColClause ReturnClause Select
deriving (Eq)
data BlockStat
= If (Seq If')
| Case (Seq If') Label
| CaseOf AExp (Seq CaseOf') Label
| Loop (Seq Stat) Label
| While AExp (Seq Stat) Label
| For Ident Bool AExp AExp (Seq Stat) Label
| ForCur Ident ProcCall (Seq Stat) Label
| ForSelect Ident Select (Seq Stat) Label
| Block (Seq Dec) (Seq Stat) (Maybe (Seq Handler)) Label
-- | ProcCall [AExp]
deriving (Eq)
data Seq a = Seq [a] Label
deriving (Eq)
emptySeq = Seq [] noLabel
data Label = Label (Maybe Ident)
deriving (Eq)
noLabel = Label Nothing
data PlType
= PlScalar Ident [AExp]
| Anchored Ident
| RowAnchored Ident
-- | PlRecord PlTypeName [PlType]
-- | PlTable PlTypeName PlTypeName
deriving (Eq)
--------------------------------------------------------------------------------
-- Display Functions
--------------------------------------------------------------------------------
nullStatOnly = Seq [NullStat] noLabel
br = (++"
")
td :: [String] -> String
td xs = hWrap ("
") " | " xs
tr :: [String] -> String
tr = hWrap "" "
"
tbl :: [String] -> String
tbl = hWrap ""
hWrap tag eTag xs = foldl (++) "" (map ((tag++) . (++eTag)) xs)
delimit c arr = dropWhile (==c) $ foldl (++) [c] (map ((c:) . show) arr)
delimitString c arr = dropWhile (==c) $ foldl (++) [c] (map ((c:)) arr)
replace :: Eq a => a-> [a] -> [a] -> [a]
replace f t s = foldl1 (\x y -> x ++ t ++ y) (filter (/=[f]) ( groupBy (\a b -> a/=f && b/=f) s ) )
escapeList l = foldl1 (.) (map (\(x,y) -> replace x y) l)
escapeHtml = escapeList [ ('<', "<"), ('>', ">") ]
chkLabelMatch (Label l) (Label el)
= (if l'==el' then l' else mismatch)
where l' = (showMaybe l)
el' = (showMaybe el)
mismatch = err l' ++ (eMsgLabelMismatch) ++ (err el')
--showMaybeS :: (Maybe String) -> String
--showMaybeS (Just a) = a
--showMaybeS Nothing = ""
showMaybe :: Show a => (Maybe a) -> String
showMaybe (Just a) = show a
showMaybe Nothing = ""
showMaybePre :: Show a => String -> (Maybe a) -> String
showMaybePre pre (Just a) = pre ++ ' ': show a
showMaybePre _ Nothing = ""
eMsgLabelMismatch = errLink "#top" "End Label Mismatch: "
eUnqualified = errLink "#top" "Unqaulified identifier in SQL"
eGoto = errLink "#top" "GOTO"
eWhenOthersNull = errLink "#top" "WHEN OTHERS NULL"
eRbackSegment = errLink "#top" "ROLLBACK SEGMENT"
eFunkyCommit = errLink "#top" "UNSAFE COMMIT"
eForceTranControl = errLink "#top" "FORCE IN COMMIT/ROLLBACK"
eCommitScn = errLink "#top" "COMMIT WITH SCN"
eDynamicOpen = errLink "#top" "DYNAMIC OPEN CURSOR "
eExecuteImmediate = errLink "#top" "EXECUTE IMMEDIATE "
wWhenOthers = warnLink "#top" "OTHERS"
wNoDefault = warnLink "#top" "NO DEFAULT"
wPragma = warnLink "#top" "PRAGMA"
wLock = warnLink "#top" "LOCK "
wPipelined = warnLink "#top" "PIPELINED "
link :: (String -> String) -> String -> String -> String
link f href text = " " ++ (f text) ++ ""
errLink = link err
warnLink = link warn
err x = "" ++ x ++ ""
warn x = "" ++ x ++ ""
instance Show Label where
show (Label (Just l)) = show l
show _ = ""
instance Show If' where
show (If' bex s) = showSeq s noLabel (escapeHtml (show bex))
instance Show CaseOf' where
show (CaseOf' aex s) = showSeq s noLabel (show aex)
instance Show Handler where
show (Handler i s) = showSeq s noLabel (if (elem (NIdent "OTHERS" "") i) then (if s == nullStatOnly then eWhenOthersNull else wWhenOthers)
else delimit '|' i
)
instance Show Stat where
show (Assign v a) = br$ show v ++ " := " ++ " (" ++ (show a) ++ ")"
show (Exit b l) = br$ "EXIT " ++ show l ++ " WHEN " ++ show b
show (Goto l) = br$ eGoto ++ show l
show (ReturnStat) = "RETURN
"
show (ReturnValueStat v) = br$ "RETURN " ++ show v
show (BlockWrap n b) = show b
show (NullStat) = "NULL
"
show (RaiseStat i) = br$ "RAISE " ++ showMaybe i
show (CommitStat com wModes frc scn) = br$ "COMMIT " ++ showMaybe com
++ (if (length wModes) > 0 then eFunkyCommit else "")
++ delimitString ' ' wModes
++ ' ' : showMaybePre eForceTranControl frc
++ ' ' : showMaybePre eCommitScn scn
show (RollbackStat toSav frc) = br$ "ROLLBACK " ++ showMaybe toSav
++ ' ' : showMaybePre eForceTranControl frc
show (SavepointStat i) = br $ "SAVEPOINT " ++ show i
show (FetchStat cur vars lim) = br $ "FETCH" ++ "[" ++ show lim ++ "] " ++ show cur ++ "→" ++ delimit ',' vars
show (LockTableStat tab mode nowait) = br$ wLock ++ delimit ',' tab ++ ' ': delimitString ' ' mode ++ if nowait then " NOWAIT" else ""
show (CloseStat i) = br $ "CLOSE " ++ show i
show (SetTranStat rm isos rback name) = br$ "SET TRAN " ++ (if rm == "" then "" else "READ " ++ rm)
++ delimitString ' ' isos
++ showMaybePre eRbackSegment rback
++ ' ' : showMaybe name
show (ProcedureCall p) = br$ show p
show (OpenCurStat p) = br$ "OPEN " ++ show p
show (SelectStat s) = br$ show s
show (DynOpenCurForStat cur a) = br$ eDynamicOpen ++ show a
show (OpenCurForStat cur sel) = br$ "OPEN " ++ show cur ++ " FOR " ++ show sel
show (ExecStat e) = br$ eExecuteImmediate ++ show e
show (UpdateStat frm whr set cur rtn) =
tbl [ tr [ td [ "update " , ""]
, td [ "from" , show frm ]
, td [ "where" , show whr ]
, if cur == Nothing then "" else td [ "CURRENT OF" , show cur ]
, td [ "set" , show set ]
, td [ "returning" , show rtn ]
]
]
show (DeleteStat frm whr cur rtn) =
tbl [ tr [ td [ "delete " , ""]
, td [ "from" , show frm ]
, td [ "where" , show whr ]
, if cur == Nothing then "" else td [ "CURRENT OF" , show cur ]
, td [ "returning" , show rtn ]
]
]
show (InsertStat tab col val rtn) =
tbl [ tr [ td [ "insert " , show tab ]
, td [ "into" , show col ]
, td [ "values" , show val ]
, td [ "returning" , show rtn ]
]
]
show (InsertSelectStat tab col rtn sel) =
tbl [ tr [ td [ "insert " , show tab ]
, td [ "into" , show col ]
, td [ "returning" , show rtn ]
, td [ show sel ]
]
]
show _ = "??? Stat"
instance Show BlockStat where
show (Block decs body excps l) = showSeqs body l [show decs, showMaybe excps]
show (If elsifs) = showSeqs elsifs noLabel ["IF"]
show (Case cases l) = showSeqs cases l ["CASE"]
show (CaseOf a cases l) = showSeqs cases l ["CASE OF", show a]
show (Loop s l) = showSeqs s l ["LOOP"]
show (While cond s l) = showSeqs s l ["WHILE", escapeHtml (show cond) ]
show (For i rev low high s l) = showSeqs s l ["FOR " ++ show i
, if rev then show high ++ "←" ++ show low
else show low ++ "→" ++ show high
]
show (ForCur i p s l) = showSeqs s l ["For " ++ show i
, show p
]
show (ForSelect i sel s l) = showSeqs s l ["For " ++ show i
, show sel
]
show _ = "??? blockstat"
showSeq :: Show a => (Seq a) -> Label -> String -> String
showSeq (Seq s l) el t = tbl [ tr [ td [ br$ chkLabelMatch l el ++ t ++ " ", foldl (++) "" (map show s) ] ] ]
showSeqs :: Show a => (Seq a) -> Label -> [String] -> String
showSeqs s el t = showSeq s el (foldl1 (\x y -> if y /= "" then x ++ "
" ++ y else x) t)
instance Show a => Show (Seq a) where
show (Seq s l) = tbl [ tr [ td [ " ", foldl (++) "" (map show s)] ] ]
instance Show Dec where
show (VarDec i ref t constant nullable defaultVal) = br$ show i
++ ' ' : ref
++ ' ' : (show t)
++ (if constant then " CONSTANT " else "")
++ (if not nullable then " NOT NULL " else "")
++ " := "
++ show defaultVal
show (Pragma i args) = br$ (if i == (NIdent "EXCEPTION_INIT" "") then "PRAGMA " else wPragma) ++ show i ++ show args
show (RecordDec name attribs) = showSeqs attribs noLabel ["RECORD", show name]
show (TableDec name tabType indType n) = br$ show name ++ ' ' : show tabType ++ '[' : showMaybe indType ++ "]"
++ (if not n then " NOT NULL " else "")
show (VarrayDec name tabType len n) = br$ show name ++ ' ' : show tabType ++ '[' : show len ++ "]"
++ (if not n then " NOT NULL " else "")
show (ProcedureSpecDec name args retType pipelined) = showSeqs args noLabel
["PROCEDURE"
, (if pipelined == "" then "" else wPipelined)
, show name
, "RETURN " ++ showMaybe retType
]
show (DecWithBody spec body) = show spec ++ show body
show (DecWithSelect spec sel) = show spec ++ show sel
instance Show Ident where
show (NIdent s c) = (if c == "sql" then eUnqualified else "") ++ map toUpper s
show (QIdent s c) = (if c == "sql" then eUnqualified else "") ++ show s
show (QualIdent s c) = delimit ':' s
instance Show AExp where
show (Var a) = show a
show (IntLit a) = show a
show (StringLit a) = '\'' : (a ++ "\'")
show (AOp o l r) = show l ++ (' ':(if o == "**" then "^" else o)) ++ (' ':(show r))
show (AUnOp o l) = show l ++ (' ':o)
show (NullLiteral) = "NULL"
show (DummyAExp context) = if context == "varDec" then wNoDefault else "NULL"
show (BUnOp o r) = o ++ show r
show (BoolLit b) = show b
show (NullBoolLit) = "NULL"
show (BOp o l r) = show l ++ (' ':o) ++ (' ':(show r))
show (RelOp o l r) = show l ++ (' ':o) ++ (' ':(show r))
show (RelUnOp o l) = show l ++ (' ':o)
show (AExpList pref a) = pref ++ '(' : delimit ',' a ++ ")"
show (FunctionCall p) = show p
show (NestedSelect s) = show s
show (BetweenExpr v l h) = '(': (show l) ++ '<': (show v) ++ '<': show h
instance Show PlType where
show (PlScalar name modifiers) = show name ++ if modifiers == [] then "" else '(' : delimit ',' modifiers ++ ")"
show (Anchored name) = show name ++ "%TYPE"
show (RowAnchored name) = show name ++ "%ROWTYPE"
instance Show ActualParam where
show (UnNamedParam a) = show a
show (NamedParam name a) = show name ++ "←" ++ show a
instance Show SqlExp where
show (UnNamedSqlExp a) = show a
show (NamedSqlExp a name) = show name ++ " AS " ++ show a
instance Show ProcCall where
show (ProcCall i (Seq as _)) = show i ++ '(' : delimit ',' as ++ ")"
instance Show Select where
show (Select dist cols blk into frm whr grp hav oby rtn wth setOps)
= let showOp (SetOp op sel oby) = td [op, show sel] ++ (tr [td ["order by", show oby]])
showOps s = map showOp s
in tbl [ tr ([ td [ "select " ++ dist , show cols]
, td [ "bulk collect" , show blk ]
, td [ "into" , show into]
, td [ "from" , show frm ]
, td [ "where" , show whr ]
, td [ "group by" , show grp ]
, td [ "having" , show hav ]
, td [ "order by" , show oby ]
, td [ "returning" , show rtn ]
, td [ "with" , show wth ]
] ++ (showOps setOps)
)
]
instance Show BasicSqlClause where
show (BasicSqlClause e) = showMaybe e
instance Show WithClause where
show (WithClause cs) = let tabify (i,e) = tbl [ tr [ td [show i, show e] ] ]
in foldl (++) "" (map tabify cs)
instance Show FormalParam where
show (FormalParam i mode ref t nullable defaultVal) = br$ delimitString ' ' [ show i, mode, ref, show t
, if not nullable then " NOT NULL " else ""
, " := ", show defaultVal
]