PlslTools-0.0.2: plsl_lint/Plsl_ast.hs

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 = (++"<br>")

td :: [String] -> String
td xs = hWrap ("<td valign=\"top\" nowrap colspan=" ++ (if length xs == 1 then "0" else "1") ++ ">") "</td>" xs

tr :: [String] -> String
tr = hWrap "<tr>" "</tr>"

tbl :: [String] -> String
tbl = hWrap "<table border=1>" "</table>"

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 [ ('<', "&lt;"), ('>', "&gt;") ]

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 = " <a href=\"" ++ href ++ "\">" ++ (f text) ++ "</a>"

errLink = link err

warnLink = link warn


err x = "<b><font color=red>" ++ x ++ "</font></b>"

warn x = "<b><font color=orange>" ++ x ++ "</font></b>"


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<BR>"
   show (ReturnValueStat v) = br$ "RETURN " ++ show v
   show (BlockWrap n b) = show b
   show (NullStat) = "NULL<BR>"
   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 ++ "&rarr;" ++ 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 ++ "&larr;" ++ show low 
                                                         else show low ++ "&rarr;" ++ 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 ++ "&nbsp;",   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 ++ "<br>" ++ y else x) t)

instance Show a => Show (Seq a) where
   show (Seq s l) = tbl [ tr [ td [ "&nbsp;",  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 ++ "&larr;" ++ 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
                                                                               ]