diff --git a/HESQL/Parser.hs b/HESQL/Parser.hs --- a/HESQL/Parser.hs +++ b/HESQL/Parser.hs @@ -30,17 +30,19 @@ whiteSpace char '=' whiteSpace - maybeOpt <- maybeOpt + 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 maybeOpt stmt + return $ HesqlDecls fn p queryOpt stmt -maybeOpt = - (reserved "maybe" >> return True) <|> return False +queryOpt = + (reserved "maybe" >> return MaybeQuery) <|> + (reserved "lazy" >> return LazyQuery) <|> + return StrictQuery sqlStatement :: Parser String sqlStatement = do @@ -76,126 +78,6 @@ 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 '.') @@ -216,10 +98,3 @@ 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) diff --git a/HESQL/Syntax.hs b/HESQL/Syntax.hs --- a/HESQL/Syntax.hs +++ b/HESQL/Syntax.hs @@ -17,152 +17,14 @@ data HesqlDecls = HesqlDecls { declName :: DeclName , declVars :: Vars - , declMaybe :: Bool + , declOpt :: QueryOpt , declSQL :: Statement } deriving Show -data SQL = SELECT SelectColumns (Maybe 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 | SqlEqualOrGreater | SqlEqualOrLess | - SqlAnd | SqlOr | - SqlIs | - SqlPlus | SqlMult | SqlMinus | SqlDiv +data QueryOpt = LazyQuery | StrictQuery | MaybeQuery 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 ++ 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 (showSqlExp . fst) cols -- TODO Alias -showColumns _ = todo "showColumns" - -showFrom Nothing = "" -showFrom (Just table) = " from " ++ 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 ++ "'" -showSqlValue (SqlInteger i) = show i -showSqlValue (SqlDouble d) = show d - -comaSepList = intercalate ", " -withParens s = "(" ++ s ++ ")" - - -todo s = error ("TODO " ++ s) - --- data SelectOption = Strict | ReturnMaybe deriving (Show, Eq) -data SelectColumns = AllColumns | ExplicitColumns [(SqlExp, 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 SqlEqualOrGreater = ">=" -infixOpToString SqlEqualOrLess = "<=" -infixOpToString SqlLess = "<" -infixOpToString SqlAnd = "and" -infixOpToString SqlOr = "or" -infixOpToString SqlIs = "is" -infixOpToString SqlPlus = "+" -infixOpToString SqlMinus = "-" -infixOpToString SqlDiv = "/" -infixOpToString SqlMult = "*" - - isSelect (SelectStatement _ _) = True isSelect _ = False -{-selectOpts :: SQL -> [SelectOption] -selectOpts (SELECT opts _ _ _ _ _) = opts -selectOpts _ = [] -} - ---selectColumns (SELECT _ cols _ _ _ _) = cols - -selectColumnLength (SelectStatement _ (Select _ _ (SelectList _ l _) _ _ _ _ _ _ _ _)) = length l +selectColumnLength (SelectStatement _ (Select _ _ (SelectList _ l _) _ _ _ _ _ _ _)) = length l diff --git a/HESQL/Translator.hs b/HESQL/Translator.hs --- a/HESQL/Translator.hs +++ b/HESQL/Translator.hs @@ -78,12 +78,11 @@ (HsUnGuardedRhs $ HsApp (HsVar $ UnQual $ HsIdent $ stmtRecName decl) (hsvar "h")) [] -resultStmt decl stmt = HsQualifier $ hsapps "fmap" [HsParen (hsapp "fmap" (hsvar "toTuple")), HsParen (hsapp (prefix++suffix) stmt)] - where suffix - | otherwise = "" - prefix - | declMaybe decl = "fetchRow" - | otherwise = "fetchAllRows'" +resultStmt decl stmt = HsQualifier $ hsapps "fmap" [HsParen (hsapp "fmap" (hsvar "toTuple")), HsParen (hsapp (fetchFun opt) stmt)] + where opt = declOpt decl + fetchFun MaybeQuery = "fetchRow" + fetchFun StrictQuery = "fetchAllRows'" + fetchFun LazyQuery = "fetchAllRows" tupleFun n = HsFunBind [ @@ -98,70 +97,7 @@ lvar i = HsIdent $ "v" ++ show i convVar v = hsapp "fromSql" (HsVar (UnQual v)) -{- -placeHolderCols AllColumns = [] -placeHolderCols (ExplicitColumns cols) = - concatMap placeHoldersExp $ map fst cols -placeHoldersSql (SELECT _ cols from wh ord grp) = - placeHolderCols cols ++ maybe [] placeHoldersExp wh - -placeHoldersSql (INSERT _ _ vals) = - concatMap placeHoldersExp vals - -placeHoldersSql (UPDATE _ updates wh) = - concatMap (placeHoldersExp . snd) updates ++ - maybe [] placeHoldersExp wh - -placeHoldersExp (SqlPlaceHolder ph) = [ph] -placeHoldersExp (SqlInfixApp e1 _ e2) = placeHoldersExp e1 ++ placeHoldersExp e2 -placeHoldersExp (SqlColumn _) = [] -placeHoldersExp (SqlFunApp n args) = concatMap placeHoldersExp args -placeHoldersExp (SqlLiteral _) = [] -placeHoldersExp (SqlNot e) = placeHoldersExp e - - - -substituteVarsExp vars (SqlInfixApp e1 op e2) = - SqlInfixApp e1' op e2' - where e1' = substituteVarsExp vars e1 - e2' = substituteVarsExp vars e2 - -substituteVarsExp _ sql@(SqlPlaceHolder _) = sql -substituteVarsExp _ sql@(SqlLiteral _) = sql -substituteVarsExp vars sql@(SqlColumn col) - | col `elem` vars = SqlPlaceHolder col - | otherwise = sql -substituteVarsExp vars (SqlNot e) = SqlNot (substituteVarsExp vars e) - -substituteVarsExp vars (SqlFunApp n args) = - SqlFunApp n (map (substituteVarsExp vars) args) - -substituteVarsSql vars (SELECT opt cols from wh ord grp) = - SELECT opt cols from - wh' - ord grp - where wh' :: Maybe SqlExp - wh' = fmap (substituteVarsExp vars) wh - -substituteVarsSql vars (INSERT tab spec vals) = - INSERT tab spec $ map (substituteVarsExp vars) vals - -substituteVarsSql vars (UPDATE tab updates wh) = - UPDATE tab updates' $ fmap (substituteVarsExp vars) wh - where updates' = map (mapSnd $ substituteVarsExp vars) updates - - - -mapSnd f (a, b) = (a, f b) - - -selectColumnLength (ExplicitColumns cols) = length cols - - --} - - substituteVarsSql :: [String] -> Statement -> Statement substituteVarsSql vars sql = case sql of @@ -169,12 +105,16 @@ Update ann table sets wh sl -> Update ann table (substituteSetClauselList vars sets) - (fmap (substituteExpression vars) wh ) - (fmap (substituteSelectList vars) sl) + (fmap substE wh ) + (substMSL sl) Insert ann tab cols e sl -> Insert ann tab cols (substituteSelectExpression vars e) sl - _ -> todo "substituteVarsSql" + Delete ann s wh msl -> + Delete ann s (fmap substE wh) (substMSL msl) + _ -> error $ "substituteVarsSql: " ++ show sql + where substE = substituteExpression vars + substMSL = fmap $ substituteSelectList vars substituteSetClauselList vars = map (substituteSetClausel vars) @@ -185,7 +125,7 @@ substituteSelectExpression vars sql = case sql of - Select ann dist sl tabref wh groupby having order dir a b -> + Select ann dist sl tabref wh groupby having order a b -> -- TODO names for a? and b? Select ann dist (substituteSelectList vars sl) @@ -193,14 +133,14 @@ (se' wh) (map se groupby) (se' having) - (map se order) - dir + (map sde order) (se' a) (se' b) Values ann el -> Values ann (map (map (substituteExpression vars)) el) where se = substituteExpression vars se' = fmap se + sde (e, dir) = (se e, dir) substituteExpression :: [String] -> Expression -> Expression @@ -214,7 +154,41 @@ case v `elemIndex` vars of Nothing -> id Just i -> PositionalArg ann (fromIntegral i+1) -substituteExpression _ l = error $ "substituteExpression: " ++ show l +substituteExpression vars (Case ann l e) = + Case ann l' e' + where e' = fmap substE e + l' = map substOneCase l + substE = substituteExpression vars + substOneCase (cs, e) = (map substE cs, substE e) + +substituteExpression vars (CaseSimple ann e1 l e2) = + CaseSimple ann e1' l' e2' + where e1' = substE e1 + e2' = fmap substE e2 + l' = map substOneCase l + substE = substituteExpression vars + substOneCase (cs, e) = (map substE cs, substE e) + +substituteExpression vars (Cast ann e tn) = + Cast ann (substituteExpression vars e) tn + +substituteExpression vars (Exists ann e) = + Exists ann (substituteSelectExpression vars e) + +substituteExpression vars l@(NullLit _) = l + +substituteExpression vars (PositionalArg _ _) + = error "don't use PositionalArg" + +substituteExpression vars (ScalarSubQuery ann se) = + ScalarSubQuery ann (substituteSelectExpression vars se) + + +substituteExpression vars (WindowFn ann e el1 el2 dir) = + WindowFn ann (substE e) (substEL el1) (substEL el2) dir + where substE = substituteExpression vars + substEL = map substE + substituteSelectList vars (SelectList ann sis sl) = SelectList ann sis' sl where sis' = map (substituteSelectItem vars) sis diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -15,6 +15,7 @@ ./Setup install dist: Setup + darcs record ./Setup sdist .PHONY: all clean install dist diff --git a/hesql.cabal b/hesql.cabal --- a/hesql.cabal +++ b/hesql.cabal @@ -1,5 +1,5 @@ Name: hesql -Version: 0.5 +Version: 0.6 Author: Christoph Bauer Maintainer: Christoph Bauer Cabal-Version: >= 1.2 @@ -13,8 +13,8 @@ Executable hesql Main-is: HESQL.hs - Build-depends: base >= 2 && < 4, HDBC, HDBC-postgresql, haskell-src, - filepath, parsec, hssqlppp >= 0.0.9 + Build-depends: base >= 4 && < 5, HDBC, HDBC-postgresql, haskell-src, + filepath, parsec, hssqlppp >= 0.0.10 Extensions: FlexibleContexts Ghc-Options: -funbox-strict-fields Other-Modules: HESQL.Parser, HESQL.Translator, HESQL.Syntax,