hesql 0.5 → 0.6
raw patch · 5 files changed
+63/−351 lines, 5 filesdep ~basedep ~hssqlppp
Dependency ranges changed: base, hssqlppp
Files
- HESQL/Parser.hs +6/−131
- HESQL/Syntax.hs +3/−141
- HESQL/Translator.hs +50/−76
- Makefile +1/−0
- hesql.cabal +3/−3
HESQL/Parser.hs view
@@ -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)
HESQL/Syntax.hs view
@@ -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
HESQL/Translator.hs view
@@ -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
Makefile view
@@ -15,6 +15,7 @@ ./Setup install dist: Setup+ darcs record ./Setup sdist .PHONY: all clean install dist
hesql.cabal view
@@ -1,5 +1,5 @@ Name: hesql-Version: 0.5+Version: 0.6 Author: Christoph Bauer <ich@christoph-bauer.net> Maintainer: Christoph Bauer <ich@christoph-bauer.net> 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,