hesql-0.1: HESQL/Syntax.hs

module HESQL.Syntax where

import Database.HDBC (SqlValue(..))
import Data.List (intercalate)

type ModuleName = String
type DeclName = String
type Vars = [String]
type TableName = String
type ColName = String
type ColAlias = String
type FunName = String

data HesqlModule = HesqlModule ModuleName [HesqlDecls] deriving (Show)
data HesqlDecls = HesqlDecls { 
      declName :: DeclName
    , declVars :: Vars 
    , declSQL  :: SQL 
  } deriving Show

data SQL = SELECT [SelectOption] SelectColumns From 
              (Maybe SqlExp)  (Maybe SqlOrder) (Maybe Group)
         | INSERT TableName InsertColumns [SqlExp]
         | UPDATE TableName [(ColName, SqlExp)] (Maybe SqlExp)
         | DELETE TableName (Maybe SqlExp)
         | DummySQL


data SqlExp = 
    SqlFunApp FunName [SqlExp] | 
    SqlInfixApp  SqlExp SqlInfixOp SqlExp |
    SqlPlaceHolder String | SqlLiteral SqlValue | SqlColumn ColName |
    SqlNot SqlExp
  deriving Show

data SqlInfixOp = SqlEqual | SqlLike | SqlLess | 
                  SqlGreater | SqlAnd | SqlOr |
                  SqlIs |
                  SqlPlus | SqlMult | SqlMinus | SqlDiv
  deriving Show


data SqlOrderDirection = ASC | DESC
   deriving Show

type SqlOrder = [(SqlExp, Maybe SqlOrderDirection)]


instance Show SQL where
    show = sqlToString 


infixPrio SqlEqual = 3
infixPrio SqlLike = 3
infixPrio SqlLess = 3
infixPrio SqlGreater = 3
infixPrio SqlIs = 3
infixPrio SqlAnd = 4
infixPrio SqlOr = 5
infixPrio SqlPlus = 1
infixPrio SqlMinus = 1
infixPrio SqlMult = 2
infixPrio SqlDiv = 2


sqlToString :: SQL -> String
sqlToString DummySQL = ""
sqlToString (SELECT _ cols from wh order group) = 
      "select " ++ showColumns cols ++ " from " ++ showFrom from
                ++ showWhere wh ++ showOrder order
-- TODO where order group
sqlToString (INSERT tab spec vals) =
    "insert into " ++ tab ++ " " ++ 
         (withParens $ comaSepList spec) ++
         " values " ++ 
         (withParens $ comaSepList $ map showSqlExp vals)

sqlToString (UPDATE tab updates wh) =
    "update " ++ tab ++ " set " ++ 
         (comaSepList $ map updateStr updates) ++
         showWhere wh
    where updateStr (col, e) = col ++ " = " ++ showSqlExp e

sqlToString (DELETE tab wh) =
    "delete from " ++ tab ++ showWhere wh


showColumns :: SelectColumns -> String
showColumns (ExplicitColumns cols) = comaSepList $ map fst cols -- TODO Alias
showColumns _ = todo "showColumns"

showFrom  table = table

showWhere Nothing = ""
showWhere (Just sqlExp) = " where " ++ showSqlExp sqlExp

showOrder Nothing = ""
showOrder (Just sqlOrder) = " order by " ++
                   (comaSepList $ map orderStr sqlOrder)
               where orderStr (sqlExp, Nothing) = showSqlExp sqlExp
                     orderStr (sqlExp, Just order) = showSqlExp sqlExp ++ " " ++ show order

showSqlExp = showSqlExp' 5

showSqlExp' p (SqlColumn n) = n
showSqlExp' p (SqlInfixApp a op b) =  par (showSqlExp' p' a ++ " " ++ infixOpToString op ++ 
                                     " " ++ showSqlExp' p' b)
    where par = if p' > p then withParens else id
          p'  = infixPrio op
showSqlExp' p (SqlPlaceHolder _) = "?"
showSqlExp' p (SqlFunApp f args) = f ++ (withParens $ comaSepList $ map showSqlExp args)
showSqlExp' p (SqlLiteral v) = showSqlValue v 
showSqlExp' p (SqlNot e) = "not " ++ showSqlExp e

showSqlValue (SqlBool b) = show b
showSqlValue SqlNull = "null"
showSqlValue (SqlString s) = "'" ++ s ++ "'"

comaSepList = intercalate ", "
withParens s = "(" ++ s ++ ")"

                                  
todo s = error ("TODO " ++ s)         

data SelectOption = Strict | ReturnMaybe deriving (Show, Eq)
data SelectColumns = AllColumns | ExplicitColumns [(ColName, Maybe ColAlias)] deriving Show
-- data From = FromSubQuery SQL | FromTables [(TableName, TableAlias)] deriving Show
type From = TableName 
type InsertColumns = [ColName]

type TableAlias = String

type Group = ()



infixOpToString SqlEqual = "="
infixOpToString SqlLike = "like"
infixOpToString SqlGreater = ">"
infixOpToString SqlLess = "<"
infixOpToString SqlAnd = "and"
infixOpToString SqlOr = "or"
infixOpToString SqlIs = "is"
infixOpToString SqlPlus = "+"
infixOpToString SqlMinus = "-"
infixOpToString SqlDiv = "/"
infixOpToString SqlMult = "*"
                       

isSelect (SELECT _ _ _ _ _ _) = True
isSelect _ = False

selectOpts :: SQL -> [SelectOption]
selectOpts (SELECT opts _ _ _ _ _) = opts
selectOpts _ = []

selectColumns (SELECT _ cols _ _ _ _) = cols