module Plsl_parse( prettyWhileFromFile ) 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.
-}


{-------------------------------------------------------------------------------------------------------- 
 - PL_LINT - a lint for pl/sql with html output
 -
 - Still to do:
 -              - cursor variables
 -              - views
 -              - triggers
 -              - insert statement - insert all 
 -              - merge statement
 -              - execute immediate - using and into clauses 
 -              - interval literals
 -              - open-for statement - using clause
 -              - sql cursor - cursor attribute %bulk_rowcount(index)
 -                           - cursor attribute %bulk_exceptions(index).[error_index|errorCode]
 -              - select -
 -                       - ansi joins 
 -                       - analytics
 -                       - grouping sets, cube, rollup
 -                       - model clause (I don't really want to bother with this one)
 -                       - partition syntax in from clause -- may already work
 -              - returning into cluase - need to test
 -              - order clause - siblings
 -                             - nulls [first|last]
 -
 -
 -------------------------------------------------------------------------------------------------------}

import Plsl_ast
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language( javaStyle )
import Maybe
import System
import Data.Char


prettyWhileFromFile fname oname
  = do{ input <- readFile fname
--      ; putStr input
      ; putStr ("Parsing: " ++ fname ++ " ... \n") 
      ; case runParser program "plsql" fname input of
           Left err -> do{ putStr "parse error at "
                           ; print err
                           }
           Right x  -> (do{ writeFile oname $ show x
                          ; putStr ("Output Written to: " ++ oname ++ "\n")
                          ; eCode <- system oname
                          ; return ()
                          }
                       )
      }

type GP = GenParser Char Context

--program :: GP Program
program = do{ try whiteSpace
            ; option () cr
            ; b <- choice [ embed ProgramStat block <?> "block"
                          , embed ProgramDec function <?> "function"
                          , embed ProgramDec procedure <?> "procedure"
                          , embed ProgramDec package <?> "package"
                          ]
--            ; b <- embed ProgramStat block
            ; semi
            ; option () (reservedOp "/")
            ; eof
            ; return $ b
            }
  where cr = do{ reserved "create"
                 ; reservedIgnore "or"
                 ; reservedIgnore "replace"
                 } 



select = select' True

select' :: Bool -> GP Select 
select' doOp = do{                                                                        ; prevContext <- getState; setState "sql"
                 ; wths <- option (WithClause []) withClause 
                 ; reserved "select"                                            
                 ; dist <- option "" (choice [ reservedRet "distinct"
                                             , reservedRet "unique"
                                             , reservedRet "all"
                                             ]
                                     )
                ; cols <- sepBy1 sqlExp comma
                ; blk  <- getClause ["bulk", "collect", "into"]  
                ; into <- getClause ["into"]                                              ; setState "from clause"
                ; frm  <- getClause ["from"]                                              ; setState "sql"          
                ; whr  <- getClause ["where"]
                ; grp  <- getClause ["group", "by"]
                ; hav  <- getClause ["having"]
                ; oby  <- getClause ["order", "by"]
                ; rtn  <- getClause ["returning"]   
                ; setOps <- if doOp then option [] (many1 setOp) else return []           ; setState prevContext
                ; return $ Select dist cols (bs blk) (bs into) (FromClause frm) (bs whr) 
                                            (bs grp) (bs hav) (bs oby) (bs rtn) 
                                            wths setOps
                }

ignore igs = foldl1 (>>) (map (try . reserved) igs)

bs c = BasicSqlClause (if c == [] then Nothing else Just c)

getClause igs = do{ clause <- try $ option [] $ (ignore igs) >> (sepBy1 sqlExp comma)
                            ; return clause
                            }
          
setOp = do{ op <- choice [ try ( do{ try (reserved "union"); reserved "all"; return "union all"}) 
                         , reservedRet "intersect"
                         , reservedRet "minus"
                         , try (reservedRet "union")
                         ]
          ; sel <- choice [ try$ select' False, try$ parens select]
          ; oby  <- getClause ["order", "by"]
          ; return $ SetOp op sel (bs oby)
          }

withClause = do{ reserved "with"
               ; withs <- sepBy1 withClause' comma
               ; return $ WithClause withs
               }

withClause' = do{ i <- unQualIdentifier
                ; reserved "as"
                ; e <- sqlExp
                ; return ( (i "with clause") , e)
                }


updateStat :: GP Stat
updateStat = do{ reserved "update"                                                        ; prevContext <- getState; setState "from clause"
                ; frm  <- option [] (sepBy1 sqlExp comma)                                 ; setState "sql"          
                ; set  <- getClause ["set"]
                ; cur  <- option Nothing (try currentOf)
                ; whr  <- getClause ["where"]
                ; rtn  <- getClause ["returning"]                                         ; setState prevContext
                ; return $ UpdateStat (FromClause frm) (bs whr) (bs set)  cur (bs rtn) 
                }

deleteStat :: GP Stat
deleteStat = do{ reserved "delete"                                                        ; prevContext <- getState; setState "from clause"
               ; option () (reserved "from")
               ; frm  <- option [] (sepBy1 sqlExp comma)                                  ; setState "sql"          
               ; whr  <- getClause ["where"]                                         
               ; cur  <- option Nothing (try currentOf)
               ; rtn  <- getClause ["returning"]                                          ; setState prevContext
               ; return $ DeleteStat (FromClause frm) (bs whr) cur (bs rtn) 
               }

insertStat :: GP Stat
insertStat = do{ reserved "insert"                                                        ; prevContext <- getState
               ; reserved "into"                                                          ; setState "insert table"
               ; tab <- plIdentifier                                                      ; setState "insert list"
               ; cols <- parens (sepBy1 sqlExp comma)                                     ; setState "sql"          
               ; reserved "values"
               ; vals  <- parens (sepBy1 sqlExp comma)
               ; rtn  <- getClause ["returning"]                                          ; setState prevContext
               ; return $ InsertStat tab (bs cols) (bs vals) (bs rtn) 
               }

insertSelectStat :: GP Stat
insertSelectStat = do{ reserved "insert"                                                        ; prevContext <- getState
                     ; reserved "into"                                                          ; setState "insert table"
                     ; tab <- plIdentifier                                                      ; setState "insert list"
                     ; cols <- parens (sepBy1 sqlExp comma)                                     ; setState "sql"          
                     ; sel <- select
                     ; rtn  <- getClause ["returning"]                                          ; setState prevContext
                     ; return $ InsertSelectStat tab (bs cols) (bs rtn) sel
                     }

currentOf = do{ try $ reserved "where"
              ; reserved "current"
              ; reserved "of"
              ; i <- plIdentifier
              ; return $ Just i 
              }

sLabel :: GP Label
sLabel = do{ sl <- option (Label Nothing) (do{ symbol "<<"
                                             ; l <- unQualIdentifier
                                             ; symbol ">>"
                                             ; return $ Label (Just (l "label"))
                                             }
                                           )
           ; return sl
           }

endLabel :: GP Label
endLabel = do{ l <- option Nothing (do {l' <- try unQualIdentifier; return (Just (l' "endlabel"))} )
             ; return $ Label l
             }


pragmaDec = do{ reserved "pragma"
              ; i <- simpleIdentifier
              ; args <- option [] anyParen
              ; return $ Pragma (i "pragma") args 
              }

anyParen = do{ symbol "("
             ; a <- many (try $ satisfy (\x -> x /= ')')) 
             ; symbol ")"
             ; return a
             }

varrayDec = do{ reserved "type"
              ; name <- unQualIdentifier
              ; reserved "is"
              ; choice [reserved "varray", reserved "varying" >> reserved "array"]
              ; len <- parens intLiteral
              ; reserved "of"
              ; tabType <- plIdentifier
              ; tabModifiers <- option [] ( parens (sepBy1 intLiteral comma) )
              ; nullable <- option True  (reserved "not" >> reserved "null" >> return False)
              ; return $ VarrayDec (name "varray dec") (PlScalar tabType tabModifiers) len nullable
              }

tableDec = do{ reserved "type"
             ; name <- unQualIdentifier
             ; reserved "is"
             ; reserved "table"
             ; reserved "of"
             ; tabType <- plIdentifier
             ; tabModifiers <- option [] ( parens (sepBy1 intLiteral comma) )
             ; iBy <- option Nothing indexBy
             ; nullable <- option True  (reserved "not" >> reserved "null" >> return False)
             ; return $ TableDec (name "table dec") (PlScalar tabType tabModifiers) iBy nullable
             }
      where indexBy = do{
                        ; reserved "index"
                        ; reserved "by"
                        ; indType <- plIdentifier
                        ; indModifiers <- option [] ( parens (sepBy1 intLiteral comma) )
                        ; return $ Just (PlScalar indType indModifiers)
                        }

recordDec = do{ reserved "type"
              ; name <- unQualIdentifier
              ; reserved "is"
              ; reserved "record"
              ; prevState <- getState; setState "record dec"
              ; attribs <- parens ( sepBy1 varDec comma)
              ; setState prevState
              ; return $ RecordDec (name "record dec") (Seq attribs noLabel)
              }

inOut = do{ i <- option "" $ reservedRet "IN"
          ; o <- option "" $ reservedRet "OUT"
          ; c <- option "" $ reservedRet "NOCOPY"
          ; return $ (if i == "" then if o == "" then "IN " else "OUT " else "IN " ++ o) ++ c
          }

formalParam = do { name <- unQualIdentifier
                 ; mode <- inOut
                 ; ref <- option "" (reservedRet "ref")
                 ; t <- plIdentifier
                 ; anch <- option False (reserved "%TYPE" >> return True)
                 ; rowAnch <- option False (reserved "%ROWTYPE" >> return True)
                 ; nullable <- option True  (reserved "not" >> reserved "null" >> return False)
                 ; defaultVal <- option (DummyAExp "formal param") defaultExpr
                 ; return $ FormalParam (name "formal param")
                            mode
                            ref
                            (if rowAnch then RowAnchored t else if anch then Anchored t else PlScalar t [])
                            nullable 
                            defaultVal
                 }

formalParamList :: GP [FormalParam]
formalParamList = do{ ps <- parens $ sepBy formalParam comma
                    ; return ps 
                    }


cursor :: GP Dec
cursor = do{ spec <- cursorSpec
           ; reserved "is"
           ; sel <- select
           ; return $ DecWithSelect spec sel
           }


cursorSpec :: GP Dec
cursorSpec = procedureSpec' "cursor"

functionSpec :: GP Dec
functionSpec = procedureSpec' "function"

              
function :: GP Dec
function = do{ spec <- functionSpec
             ; body <- procedureBody $ getLabel spec 
             ; return $ DecWithBody spec body
             }
          where getLabel (ProcedureSpecDec name _ _ _) = name

package :: GP Dec
package = do{ spec <- procedureSpec' "package"
              ; body <- procedureBody $ getLabel spec 
              ; return $ DecWithBody spec body
              }
          where getLabel (ProcedureSpecDec name _ _ _) = name


procedureSpec = procedureSpec' "procedure"

procedureSpec' :: String -> GP Dec
procedureSpec' start = do{ reserved start
                         ; reservedIgnore "body" -- hack for package bodies
                         ; name <- plIdentifier -- was unQualIdentifier but needs to be qualifiable in create statements
                         ; args <- option [] ( try formalParamList) 
                         ; retType <- option Nothing (do{reserved "return"; retType <- plIdentifier; return $ Just retType})
                         ; reservedIgnore "deterministic"
                         ; reservedIgnore "parallel_enable"
                         ; reservedIgnore "deterministic"
                         ; reservedIgnore "authid"
                         ; reservedIgnore "current_user"
                         ; reservedIgnore "definer"
                         ; pipelined <- option "" (reservedRet "pipelined")
                         ; return $ ProcedureSpecDec (Label (Just (name {-"label"-}))) (Seq args noLabel) retType pipelined 
                         }

procedure :: GP Dec 
procedure = do{ spec <- procedureSpec
              ; body <- procedureBody $ getLabel spec 
              ; return $ DecWithBody spec body
              }
          where getLabel (ProcedureSpecDec name _ _ _) = name

procedureBody :: Label ->  GP BlockStat
procedureBody l = do { d <- option (Seq [] noLabel) (dec ["is","as"])
                   ; b <- option (Seq [] noLabel) (try body)
                   ; h <- handler
                   ; reserved "end"
                   ; el <- endLabel
                   ; return $ Block d b h el
                   }
       where body = do{ reserved "begin"; stats <- seqStat l; return stats }
     

dec :: [String] -> GP (Seq Dec)
dec startWords = do{ choice (map reserved startWords)
                  ; d <- endBy dec' semi
                  ; return $ Seq d noLabel
                  }

dec' = choice [ varDec
                , try procedure <|> try procedureSpec 
                , try function
                , try functionSpec
                , try cursor
                , try cursorSpec
                , pragmaDec
                , try recordDec
                , try tableDec
                , try varrayDec
              ] 



varDec :: GP Dec
varDec = do{ context <- getState
           ; id <- plIdentifier
           ; ref <- option "" (reservedRet "ref")
           ; constant <- option False (reserved "constant" >> return True)
           ; t <- choice [ plIdentifier, embed (\x -> NIdent x "exception dec")  (reservedRet "exception") ]
           ; modifiers <- option [] ( parens (sepBy1 intLiteral comma) )
           ; anch <- option False (reserved "%TYPE" >> return True)
           ; rowAnch <- option False (reserved "%ROWTYPE" >> return True)
           ; nullable <- option True  (reserved "not" >> reserved "null" >> return False)
           ; defaultVal <- option (DummyAExp (if context /= "record dec" then "varDec" else context)) defaultExpr
           ; return $ VarDec id 
                             ref
                             (if rowAnch then RowAnchored t else if anch then Anchored t else PlScalar t modifiers)
                             constant 
                             nullable 
                             defaultVal
           }

defaultExpr :: GP AExp
defaultExpr = do{ choice [reservedOp ":=", reserved "default"]
                ; a <- expr
                ; return a
                }

plIdentifier :: GP Ident
plIdentifier = qualIdentifier

qualIdentifier :: GP Ident
qualIdentifier = do{ context <- getState
                   ; i <- sepBy1 unQualIdentifier singleDot
                   ; return $ if length i == 1 then head i context else QualIdent (fmap ($ "Qualified") i ) context
                   }

unQualIdentifier :: GP (Context -> Ident)
unQualIdentifier = do{ i <- choice [starIdentifier, quoteIdentifier, simpleIdentifier]
                     ; return $ i 
                     }

starIdentifier :: GP (Context -> Ident)
starIdentifier = do{ symbol "*"; return $ QIdent "*" }

simpleIdentifier :: GP (Context -> Ident)
simpleIdentifier = do{ i <- identifier; return $ NIdent i }

quoteIdentifier :: GP (Context -> Ident)
quoteIdentifier = do{ i <- qIdentifier; return $ QIdent i }

stat :: GP Stat
stat = choice [ try block
              , try execStat
              , try ifStat
              , try caseStat
              , try caseOfStat
              , try whileStat
              , try loopStat
              , try forStat
              , try forSelectStat
              , try forCurStat
              , try exitStat
              , try gotoStat
              , try returnValueStat
              , try returnStat
              , try assignStat
              , try raiseStat
              , try savepointStat
              , try rollbackStat
              , try commitStat
              , try fetchStat
              , try lockTableStat
              , try closeStat
              , try setTranStat
              , try openCurForStat
              , try dynOpenCurForStat
              , try openCurStat
              , try $ embed SelectStat select
              , try updateStat
              , try deleteStat
              , try insertStat
              , try insertSelectStat
              , try (reserved "null" >> return NullStat)
              , try procedureCall
              , do{ proc <- plIdentifier; return $ ProcedureCall $ ProcCall proc emptySeq}
              -- yeah this last choice is dumb but I needed a hack for procedures with no parens
             ]
       
      

execStat = do{ reserved "execute"
             ; reserved "immediate"
             ; e <- expr
             ; return $ ExecStat e
             }

openCurStat = do{ try $ reserved "open"
                ; p <- choice [try procCall, hack]
                ; return $ OpenCurStat p
                }
            where hack = do{ i <- unQualIdentifier; return $ ProcCall (i "proc call") (Seq [] noLabel)}
            -- hack is a workaround for procCall having the paren list optional

dynOpenCurForStat = do { try $ reserved "open"
                    ; cur <- unQualIdentifier
                    ; reserved "for"
                    ; e <- expr
                    ; return $ DynOpenCurForStat (cur "open for") e
                    }

openCurForStat = do { try $ reserved "open"
                    ; cur <- unQualIdentifier
                    ; reserved "for"
                    ; sel <- select
                    ; return $ OpenCurForStat (cur "open for") sel
                    }

setTranStat :: GP Stat
setTranStat = do{ reserved "set"
                ; reserved "transaction"
                ; readMode <- option "" (do{ reserved "read"
                                           ; r <- choice [reservedRet "only", reservedRet "write"]
                                           ; return r
                                           }
                                        )
                ; iso <- option [""] (do{ reserved "isolation"
                                      ; reserved "level"
                                      ; i <- choice [ count 1 (reservedRet "serializable")
                                                    , count 2 (choice [reservedRet "read", reservedRet "committed"])
                                                    ]
                                      ; return i
                                      }
                                   )
                ; rback <- option Nothing (do{ reserved "use"
                                             ; reserved "rollback"
                                             ; reserved "segment"
                                             ; rb <- unQualIdentifier
                                             ; return $ Just (rb "set tran rollback")
                                             }
                                          )
                ; name <- option Nothing
                                 (do{ reserved "name"
                                    ; n <- aritExpr
                                    ; return $ Just n
                                    }
                                 )
                ; return $ SetTranStat readMode iso rback name
                }


closeStat :: GP Stat
closeStat = do{ reserved "close"
              ; i <- plIdentifier
              ; return $ CloseStat i
              }

lockTableStat :: GP Stat
lockTableStat = do{ reserved "lock"
                  ; reserved "table"
                  ; tab <- sepBy1 plIdentifier comma
                  ; reserved "in"
                  ; mode <- sepBy1 (choice [reservedRet "SHARE", reservedRet "EXCLUSIVE", reservedRet "UPDATE", reservedRet "ROW"]) whiteSpace
                  ; reserved "mode"
                  ; nowait <- option False (reserved "nowait" >> return True)
                  ; return $ LockTableStat tab mode nowait
                  }


fetchStat :: GP Stat
fetchStat = do{ reserved "fetch"
              ; cur <- plIdentifier
              ; lim' <- option 1 (reserved "bulk" >> return 0)
              ; reservedIgnore "collect" 
              ; reserved "into"
              ; vars <- sepBy1 plIdentifier comma
              ; lim <- option (DummyAExp "limit") (do {reserved "limit"; i <- aritExpr; return i})
              ; return $ FetchStat cur vars (if lim' == 1 then (IntLit 1) else lim )
              }


commitStat :: GP Stat
commitStat = do{ reserved "commit"
                 ; reservedIgnore "work" 
                 ; com <- option Nothing (do{ reserved "comment"; a <- stringLiteral; return $ Just a})
                 ; reservedIgnore "write" 
                 ; wMode <- option [] (many1 (choice [reservedRet "immediate", reservedRet "batch", reservedRet "wait", reservedRet "nowait"]))
                 ; frc <- option Nothing (do{ reserved "force"; a <- stringLiteral; return $ Just a})
                 ; scn <- option Nothing (do{ i <- intLiteral; return $ Just i})
                 ; return $ CommitStat com wMode frc scn
                 }


rollbackStat :: GP Stat
rollbackStat = do{ reserved "rollback"
                 ; reservedIgnore "work" 
                 ; toSav <- option Nothing (do{ reserved "to";  a <- unQualIdentifier; return $ Just (a "rollback") })
                 ; frc <- option Nothing (do{ reserved "force"; a <- stringLiteral; return $ Just a})
                 ; return $ RollbackStat toSav frc
                 }

savepointStat :: GP Stat
savepointStat = do{ reserved "savepoint"
                  ; i <- unQualIdentifier
                  ; return $ SavepointStat (i "savepoint")
                  }

raiseStat :: GP Stat
raiseStat = do{ reserved "raise"
              ; i <- option Nothing (do{i <- plIdentifier; return $ Just i})
              ; return $ RaiseStat i
              }

returnStat :: GP Stat
returnStat = do{ reserved "return"
               ; return ReturnStat
               }

returnValueStat :: GP Stat
returnValueStat = do{ reserved "return"
                    ; e <- expr
                    ; return $ ReturnValueStat e
                    }
               
assignStat :: GP Stat 
assignStat = assignStat' ":="

assignStat' :: String -> GP Stat 
--assignStat' eq = do{ id <- plIdentifier
assignStat' eq = do{ id <- expr
                   ; symbol eq
                   ; e <- expr
                   ; return $ Assign id e
                   }

exitStat :: GP Stat
exitStat = choice [try (do{ reserved "exit"
                         ; l <- option noLabel endLabel
                         ; reserved "when"
                         ; b <- boolExpr
                         ; return $ Exit b l
                         })
                  ,try (do{ reserved "exit"
                         ; l <- option noLabel endLabel
                         ; return $ Exit (BoolLit True) l
                         })
                  ]

gotoStat :: GP Stat
gotoStat = do { reserved "goto"
              ; l <- endLabel
              ; return $ Goto l
              }

block :: GP Stat
block = do{ l <- sLabel
          ; d <- option (Seq [] noLabel) (dec ["declare"])
          ; reserved "begin"
          ; stats <- seqStat l
          ; h <- handler
          ; reserved "end"
          ; el <- endLabel
          ; return $ BlockWrap l (Block d stats h el)
          }

ifStat :: GP Stat 
ifStat  = do{ l <- sLabel
            ; reserved "if"
            ; cond <- boolExpr
            ; reserved "then"
            ; thenPart <- seqStat noLabel
            ; elseIfPart <- try $ many (elseIfPiece "elsif")
            ; elsePart <- try $ option [] elsePiece
            ; reserved "end"; reserved "if"
            ; return $ BlockWrap l 
                                 (If (Seq ((If' cond thenPart) : elseIfPart ++ elsePart)
                                          noLabel 
                                     )
                                 )
            }

caseStat :: GP Stat 
caseStat  = do{ l <- sLabel
              ; reserved "case"; 
              ; elseIfPart <- many1 (elseIfPiece "when")
              ; elsePart <- try $ option [] elsePiece
              ; reserved "end"; reserved "case"
              ; el <- endLabel              
              ; return $ BlockWrap l (Case (Seq( elseIfPart ++ elsePart) l ) el ) 
              }

elseIfPiece :: String -> GP If'
elseIfPiece nextCond 
   = do { reserved nextCond
        ; cond <- boolExpr
        ; reserved "then"
        ; s <- seqStat noLabel
        ; return $ If' cond s
        }

elsePiece :: GP [If']
elsePiece = do{ reserved "else"
              ; s <- seqStat noLabel
         ; return $ [If' (BoolLit True) s]
         }


caseOfStat :: GP Stat 
caseOfStat = do{ l <- sLabel
               ; reserved "case"
               ; switchOn <- aritExpr
               ; cases <- many1 caseOfPiece
               ; elseCase <- try $ option [] caseOfElsePiece
               ; reserved "end"; reserved "case"
               ; el <- endLabel
               ; return $ BlockWrap l (CaseOf switchOn (Seq (cases ++ elseCase) l) el)
               }


caseOfPiece :: GP CaseOf'
caseOfPiece = do{ reserved "when"
                ; caseVal <- aritExpr
                ; reserved "then"
                ; s <- seqStat noLabel
                ; return $ CaseOf' (Just caseVal) s
                }

caseOfElsePiece :: GP [CaseOf']
caseOfElsePiece = do{ reserved "else"
                    ; s <- seqStat noLabel
                    ; return $ [CaseOf' Nothing s ]
                    }

handler :: GP (Maybe (Seq Handler))
handler = do{ h <- option Nothing (do {reserved "exception"
                                      ; s <- many1 handlerPiece
                                      ; return $ Just ((Seq s) noLabel)
                                      }
                                  )
            ; return h
            }

handlerPiece :: GP Handler
handlerPiece = do{ reserved "when"
                 ; i <- sepBy1 plIdentifier (reserved "or")
                 ; reserved "then"
                 ; stats <- seqStat noLabel
                 ; return $ Handler i stats
                 }


loopStat :: GP Stat
loopStat = do { l <- sLabel
              ; reserved "loop"
              ; body <- seqStat l
              ; reserved "end"; reserved "loop"
              ; el <- endLabel
              ; return $ BlockWrap l (Loop body el)
              }

                 
whileStat :: GP Stat
whileStat = do{ l <- sLabel
              ; reserved "while"
              ; cond <- boolExpr
              ; reserved "loop"
              ; body <- seqStat l
              ; reserved "end"; reserved "loop"
              ; el <- endLabel
              ; return $ BlockWrap l (While cond body el)
              }

forStat :: GP Stat
forStat = do { l <- sLabel
             ; reserved "for"
             ; i <- unQualIdentifier
             ; reserved "in"
             ; rev <- option False (try $ reserved "reverse" >> return True)
             ; low <- aritExpr
             ; symbol ".."
             ; high <- aritExpr
             ; reserved "loop"
             ; body <- seqStat l
             ; reserved "end"; reserved "loop"
             ; el <- endLabel
             ; return $ BlockWrap l (For (i "plsql") rev low high body el)
             }

forCurStat = do{ l <- sLabel
               ; reserved "for"
               ; i <- unQualIdentifier
               ; reserved "in"
               ; cur <- choice [try procCall, hack]
               ; reserved "loop"
               ; body <- seqStat l
               ; reserved "end"; reserved "loop"
               ; el <- endLabel
               ; return $ BlockWrap l (ForCur (i "plsql") cur body el)
               }
         where hack = do{ i <- unQualIdentifier; return $ ProcCall (i "proc call") (Seq [] noLabel)}
            -- hack is a workaround for procCall having the paren list optional

forSelectStat = do{ l <- sLabel
                  ; reserved "for"
                  ; i <- unQualIdentifier
                  ; reserved "in"
                  ; sel <- parens select
                  ; reserved "loop"
                  ; body <- seqStat l
                  ; reserved "end"; reserved "loop"
                  ; el <- endLabel
                  ; return $ BlockWrap l (ForSelect (i "plsql") sel body el)
                  }

seqStat :: Label -> GP (Seq Stat)
seqStat l = do{ stats <- sepEndBy1 stat semi
              ; return $ Seq stats l
              }

procedureCall :: GP Stat
procedureCall = embed ProcedureCall procCall --do{ p <- procCall; return $ ProcedureCall p}

functionCall :: GP AExp 
functionCall = embed FunctionCall procCall -- do{ p <- procCall; return $ FunctionCall p}

analyticClause = do{ reserved "over"
                   ; symbol "("
                   ; part <- anaPartClause
                   ; ord  <- getClause ["order","by"]
                   ; win  <- anaWindowClause
                   ; return () -- $ AnalyticClause part ord win 
                   }

anaPartClause = return ()

anaWindowClause = return ()

procCall :: GP ProcCall
procCall = do{ --failOnReserved
             ; proc <- plIdentifier  -- unQualIdentifier -- not sure why I made this unQualIdentifier at first?
--             ; args <- option (Seq [] noLabel) actualParamList -- having this optional causes problems
--                                                               -- function calls will be fine since they will look like variables
--                                                               -- procedures calls we'll just have to live with enforcing empty parens
             ; args <- try actualParamList
             ; return $ ProcCall proc args
             }


actualParamList :: GP (Seq ActualParam)
actualParamList = do{
--                     ps <- option [] (parens $ sepBy1 (choice [try namedParam, try unNamedParam]) comma)
                     ps <- parens $ option [] ( sepBy1 (choice [try namedParam, try unNamedParam]) comma)
                    ; return $ Seq (ps) noLabel
                    }

unNamedParam = embed UnNamedParam expr -- do{ e <- expr; return $ UnNamedParam e}

namedParam = do{ name <- unQualIdentifier 
               ; reservedOp "=>"
               ; e <- expr
               ; return $ NamedParam (name "named param") e
               }

sqlExp = choice [try namedSqlExp, unNamedSqlExp]

unNamedSqlExp = embed UnNamedSqlExp expr -- do{ e <- expr; return $ UnNamedSqlExp e}
 
namedSqlExp = do{ e <- expr
                ; reservedIgnore "as"
                ; name <- unQualIdentifier
                ; return $ NamedSqlExp (name "sql alias") e
                }

expr = aritExpr
boolExpr = aritExpr

aritExpr :: GP AExp
aritExpr = buildExpressionParser aritOperators simpleArit


-- Everything mapping pairs of ints to ints
aritOperators =
    [ 
--      [ op  "." AssocLeft ] -- has strange bug where character after the dot has to be a 'v'
--      [ op  "." AssocRight ] -- same bug
--      [ oprelv (try dot)] -- fixes above bug but breaks for loops with ..
      [ Infix (singleDot >> return (\x y -> AOp "." x y) ) AssocLeft ] -- works for both for loops and v bug
    , [ isNotNull, isNull]
    , [ pct "%rowcount", pct "%bulk_rowcount", pct "%charset", pct "%found", pct "%notfound", pct "%isopen"]
    , [ op "**" AssocLeft ]
    , [ op "*"  AssocLeft, op "/"  AssocLeft ]
    , [ op "+"  AssocLeft, op "-"  AssocLeft ]
    , [ op "||" AssocLeft ] 
    , [ prefix "not"]
    , [ opbb "and" AssocRight ] -- right for shortcircuit
    , [ opbb "or" AssocRight ] -- right for shortcircuit
    , [ oprel "<", oprel ">", oprel "<=", oprel ">="]
    , [ oprel "=", oprel "<>", oprel "!=", oprel "^="
      , oprelv $ reservedRet "like", oprelv $ reservedRet "in", oprelv $ do { reserved "not"; reserved "in"; return "not in"}
      ]    
    , [ oprelv $ reservedRet  "between" ]  
--    , [ opl "union", opl "intersect", opl "minus", unionAll]
    ]
    where
{-
      opl name             = Infix (do{ reserved name
                                  ; return (\x y -> AOp name x y) 
                                  }) AssocLeft
-}
      op name assoc        = Infix (do{ reservedOp name
                                  ; return (\x y -> AOp name x y) 
                                  }) assoc
      pct suf              = Postfix (do{ try $ reservedOp suf
                                   ; return (\x -> AUnOp suf x)
                                   }
                                )
      opbb name assoc     = Infix (do{ reserved name
                                   ; return (\x y -> BOp name x y) 
                                   }) assoc
      oprel name          = Infix (do{ reservedOp name
                                   ; return (\x y -> RelOp name x y) 
                                   }) AssocLeft
      oprelv pars         = Infix (do{  name <- pars
                                   ; return (\x y -> RelOp name x y) 
                                   }) AssocLeft
      prefix name         = Prefix  (do{ reserved name
                                  ; return (\x -> BUnOp name x)
                                  })                                      
      isNull              = Postfix (do{ try ( reserved "is" >> reserved "null" )
                                      ; return (\x -> BUnOp "IS NULL:" x)
                                      }
                                   )
      isNotNull          = Postfix (do{ try (reserved "is" >> reserved "not" >> reserved "null")
                                      ; return (\x -> BUnOp "IS NOT NULL:" x)
                                      }
                                   )
{-
      unionAll           = Infix (do{ try (try $ reserved "union" >> reserved "all")
                                    ; return (\x y -> AOp "union all" x y) 
                                    }) AssocLeft
-}

simpleArit = choice [ 
                      try ( parens $ embed NestedSelect select )
--                    , try betweenExpr -- causes stack overflow
                    , try aritList
                    , try functionCall
                    , try aritListBare
                    , try intLiteral
                    , stringLiteral
                    , nullLiteral
                    , parens aritExpr
                    , embed Var plIdentifier --variable
                    , boolLiteral
                    ]

aritList' :: GP [AExp]
aritList' = do{ symbol "("
              ; a <- aritExpr
              ; comma
              ; as <- sepBy1 aritExpr comma
              ; symbol ")"
              ; return $ (a:as)
             }

betweenExpr = do{ a <- aritExpr
                ; reserved "between"
                ; b <- aritExpr
                ; reserved "and"
                ; c <- aritExpr
                ; return $ BetweenExpr a b c
                }

aritList :: GP AExp
aritList = do{ pref <- option "" (choice [reservedRet "any", reservedRet "all"])
             ; as <- aritList'
             ; return $ AExpList pref as
             }

aritListBare :: GP AExp
aritListBare = do{ as <- aritList'
                 ; return $ AExpList "" as
                 }


boolLiteral = do{ reserved "false"
                ; return (BoolLit False)
                }
              <|>  
              do{ reserved "true"
                ; return (BoolLit True)
                }
              <|>  
              do{ reserved "null"
                ; return (NullBoolLit)
                }

intLiteral = do{ i <- integer; return (IntLit i) }

nullLiteral = do{ reserved "null";
                ; return NullLiteral
                }

             
-----------------------------------------------------------
-- The lexer
-----------------------------------------------------------
lexer     = P.makeTokenParser plDef

plDef  = javaStyle
          { -- Kept the Java single line comments, but officially the language has no comments
            P.reservedNames  = reservedNames
          , P.reservedOpNames= [ "<", "<=", ">", ">=", ":=", "+", "&", "-", "/", "||", "*", "**", "..", "."
-- leave these commented out for now as they cause problems (probably also the root of the v bug)          
-- If we end up needing these then we need to populate P.opLetter with just the ones that are symbols only
--                               , "%rowcount", "%bulk_rowcount", "%charset", "%found", "%notfound", "%isopen"
                               ]
          , P.opLetter       = oneOf (concat (P.reservedOpNames plDef))
          , P.caseSensitive  = False
          , P.commentLine = "--"
          , P.identLetter = alphaNum <|> oneOf "_$#"
          }

reservedNames = [ "true", "false", "loop", "else", "not", "null", "constant"
                , "if", "elsif", "then", "case", "when", "while"
                , "declare", "begin", "procedure", "function", "return", "is", "end"
                , "parallel_enable", "deterministic", "pipelined"
                , "select", "from", "where", "group", "by", "order", "having", "as"
                , "loop", "exit", "for", "in", "out", "nocopy", "ref"
                , "raise"
                , "<<", ">>"
                , "pragma"
                , "record","table", "type","index","by", "of", "varray", "varying", "array"
                , "commit", "rollback"
                , "work", "to", "force", "batch", "immdiate", "wait", "comment"
                , "fetch", "into", "open", "close"
                , "lock", "table", "row", "share", "exclusive", "update", "nowait"
                , "set", "transaction", "only",  "isolation"
                , "serializable", "committed", "name", "use", "rollback", "segment"
                , "returning", "the", "distinct", "unique"
                , "bulk", "collect", "with", "union", "intersect", "minus"
                , "create" --, "replace" -- Can't have replace as a reserved word because it is also a supplied function name -- brilliant
                , "current", "values", "cursor", "between", "partition"
                , "exception"
                , "and", "or"  
                ,"caseZ"
                ]

parens          = P.parens lexer    
braces          = P.braces lexer    
semiSep1        = P.semiSep1 lexer    
semi            = P.semi lexer
comma           = P.comma lexer
--dot             = P.dot lexer
commaSep        = P.commaSep lexer
whiteSpace      = P.whiteSpace lexer    
symbol          = P.symbol lexer    
identifier      = P.identifier lexer    
reserved        = P.reserved lexer    
reservedOp      = P.reservedOp lexer
integer         = P.integer lexer    
charLiteral     = P.charLiteral lexer    



qIdentifier = P.stringLiteral lexer

stringLiteral 
   = do{ symbol "\'"
       ; com <- manyTill (try (do {char '\''; char '\''}) <|> satisfy(\c -> c /= '\''))  (try endQoute)
       ; return $ StringLit com
       }
   where endQoute = do{ symbol "\'"; notFollowedBy $ char '\''}

reservedRet a = do{ try $ reserved a
                  ; return $ map toUpper a
                  }

reservedIgnore s = option () (reserved s)                 

--failOn ps =  do{ foldl1 (>>) (map ( (>>pzero) . try . reserved) ps)}

--failOnReserved = failOn reservedNames

embed t p = (p >>= \x -> return $ t x)

singleDot = try ( char '.' >> notFollowedBy (char '.') )