hesql-0.5: HESQL/Parser.hs

module HESQL.Parser (hesqlModule) where

import HESQL.Syntax
import Text.Parsec.String
import Text.Parsec
import Text.Parsec.Language (haskellDef)
import Text.Parsec.Expr
import qualified Text.Parsec.Token as P
import Data.List (intercalate)
import Database.HDBC
import Control.Monad (forM_)

import Database.HsSqlPpp.Parsing.Parser


hesqlModule :: Parser HesqlModule
hesqlModule = do
  whiteSpace
  modName <- moduleHeader
  decls <- decls
  whiteSpace
  eof
  return $ HesqlModule modName decls

decls = many decl

decl = do
   fn <- funName
   p <- many parameter
   whiteSpace
   char '='
   whiteSpace
   maybeOpt <- maybeOpt
   stmtStr <- sqlStatement
   whiteSpace
   stmt <- 
     case parseSql stmtStr of
       Right [stmt] -> return stmt
       Left e -> error $ show e -- TODO proper error message, handle other Right cases
   return $ HesqlDecls fn p maybeOpt stmt

maybeOpt = 
   (reserved "maybe" >> return True) <|> return False

sqlStatement :: Parser String
sqlStatement = do
    s <- many (noneOf "\"';")
    r <- sqlStatement'
    return $ s ++ r 

sqlStatement' = do
    r <- sqlQuoted "\"" <|> sqlQuoted "'"  <|> sqlTerminator
    if (r == ";") 
       then return r
       else do
          s <- sqlStatement
          return $ r++s 
    



 
sqlQuoted s = do
  l <- between (string s) (string s) $ many qchars
  return $ s ++ concat l ++ s
 where qchars = many1 (noneOf ('\\':s)) <|> do 
                  c <- char '\\' 
                  q <- anyChar
                  return ['\\',  q]

sqlTerminator = string ";" 



funName = identifier
parameter = identifier


order = do
  reserved "order"
  reserved "by"
  sepBy1 orderCol (symbol ",")
 where orderCol = do
          e   <- sqlExp
          ord <- optionMaybe orderDir
          return (e, ord)
       orderDir = (reserved "asc" >> return ASC)<|>
                  (reserved "desc" >> return DESC)


select suffix opts = 
  reserved ("select"++suffix) >> return opts

insertStatement = do
  reserved "insert"
  reserved "into"
  tab <- table
  spec <- insertSpec
  reserved "values"
  values <- insertValues 
  return $ INSERT tab spec values

updateStatement = do
  reserved "update"
  tab <- table
  reserved "set"
  updates <- updates
  wh <- optionMaybe whereCondition
  return $ UPDATE tab updates wh

deleteStatement = do
  reserved "delete"
  reserved "from"
  tab <- table
  wh <- optionMaybe whereCondition
  return $ DELETE tab wh


updates = sepBy1 set (symbol ",")
     where set = do
             col <- columnName
             symbol "="
             e <- sqlExp 
             return (col, e)
  

insertSpec = 
  parens $ sepBy1 identifier (symbol ",")

insertValues =
    parens $ sepBy1 sqlExp (symbol ",")

whereCondition :: Parser SqlExp
whereCondition = do
  reserved "where"
  be <- sqlExp
  return be

sqlExp = sqlCompare 

sqlCompare = buildExpressionParser table sqlTerm
   where table = [ [prefix (reserved "not") SqlNot]
                 , [binary "+" SqlPlus AssocLeft, binary "-" SqlMinus AssocLeft]
                 , [binary "*" SqlMult AssocLeft, binary "/" SqlDiv AssocLeft]
                 , [binary "is" SqlIs AssocRight]
                 , [binary "=" SqlEqual AssocLeft, binary "<" SqlLess AssocLeft, 
                    binary ">" SqlGreater AssocLeft,
                    binary ">=" SqlEqualOrGreater AssocLeft,
                    binary "<=" SqlEqualOrLess AssocLeft]
                 , [binary "and" SqlAnd AssocLeft]
                 , [binary "or" SqlOr AssocLeft]
                 ]

sqlBoolLiteral = 
  kw "true" (SqlLiteral (toSql True)) <|>
  kw "true" (SqlLiteral (toSql True)) <|>
  kw "null" (SqlLiteral SqlNull)
 where kw s v = reserved s >> return v

sqlLiteral = sqlBoolLiteral <|> 
             sqlStringLiteral <|>
             sqlNumberLiteral

sqlStringLiteral =
    between (symbol "'") (symbol "'") $ do
      s <- many stringChar
      return (SqlLiteral (toSql (s :: String)))
   where stringChar = 
           noneOf "\\'" <|> do
             char '\\'
             char '\''  -- TODO \n etc

sqlNumberLiteral = do
  n <- naturalOrFloat
  case n of 
    Left i -> return $ SqlLiteral (toSql i)
    Right f -> return $ SqlLiteral (toSql f)


    

sqlTerm = parens sqlExp <|> sqlLiteral <|> do 
  n <- identifier
  funParams n <|> return (SqlColumn n)

       
funParams n = do
  args <- parens $ sepBy sqlExp (symbol ",")
  return $ SqlFunApp n args


columnName = identifier

column = do
  col <- identifier
  return (col, Nothing)

table = identifier
   
modName = sepBy1 identifier (char '.')

moduleHeader = do
  reserved "module"
  m <- modName
  reserved "where"
  return $ intercalate "." m 

lexer       = P.makeTokenParser haskellDef    
      
parens         = P.parens lexer
braces         = P.braces lexer
identifier     = P.identifier lexer
reserved       = P.reserved lexer
reservedOp     = P.reservedOp lexer
whiteSpace     = P.whiteSpace lexer
symbol         = P.symbol lexer
naturalOrFloat = P.naturalOrFloat lexer

binary  name fun assoc = Infix (do
                                 reservedOp name; 
                                 return $ \ e1 e2 -> SqlInfixApp e1 fun e2) 
                             assoc

prefix p fun = Prefix (do p >> return fun)
postfix names fun = Prefix (do forM_ names reservedOp; return fun)