hesql-0.7: HESQL/Parser.hs

module HESQL.Parser (hesqlModule) where

import HESQL.Syntax
import Text.Parsec.String
import Text.Parsec
import Text.Parsec.Language (haskellDef)

import qualified Text.Parsec.Token as P
import Data.List (intercalate)

import Database.HsSqlPpp.Parsing.Parser


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

decls :: Parser [HesqlDecls]
decls = many decl

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

queryOpt :: Parser QueryOpt
queryOpt = 
   (reserved "maybe" >> return MaybeQuery) <|>
   (reserved "lazy" >> return LazyQuery) <|> 
   return StrictQuery

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

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



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

sqlTerminator :: Parser String
sqlTerminator = string ";" 


funName :: Parser String
funName = identifier
parameter = identifier


   
moduleName = sepBy1 identifier (char '.')

moduleHeader = do
  reserved "module"
  m <- moduleName
  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