hesql-0.6: 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
   queryOpt <- queryOpt
   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 queryOpt stmt

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' = 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


   
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