hesql-0.2: 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_)


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
   stmt <- sqlStatement
   whiteSpace
   symbol ";"
   return $ HesqlDecls fn p stmt



funName = identifier
parameter = identifier

sqlStatement = 
    selectStatement <|>
    insertStatement <|>
    updateStatement <|>
    deleteStatement
               


selectStatement = do
  opts <- selectVariant
  cols <- sepBy1 column (symbol ",")
  reserved "from"
  tab <- table
  wh <- optionMaybe whereCondition
  ord <- optionMaybe order
  return $ SELECT opts (ExplicitColumns cols) tab
            wh ord Nothing

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)

selectVariant = 
    select "1'" [Strict, ReturnMaybe] <|>
    select "1"  [ReturnMaybe] <|> 
    select "'"  [Strict] <|>
    select "" []

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 "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 name fun = Prefix (do reservedOp name; return fun)
postfix names fun = Prefix (do forM_ names reservedOp; return fun)