/src-extra/tosort/examples/wrappers/ThTupleWrapper.lhs
Haskell | 133 lines | 120 code | 11 blank | 2 comment | 4 complexity | 7b35cabcd6afb1f8c928dfee3602a2f4 MD5 | raw file
Possible License(s): BSD-3-Clause
1Template Haskell code to return database queries as lists of tuples. 2 3> {-# LANGUAGE TemplateHaskell #-} 4> 5> module Database.HsSqlPpp.Examples.Wrappers.ThTupleWrapper 6> (withConn 7> ,sqlQuery 8> ,IConnection) where 9> 10> import Language.Haskell.TH 11> import Data.Maybe 12> import Control.Applicative 13> import Control.Monad.Error 14> import Database.HDBC 15> import System.IO.Unsafe 16> import Data.IORef 17> -- the select relation from the library returns strings, but 18> -- we want the completely pointless wrapper which gives us sqlvalues, 19> -- which we can cast better 20> import Database.HsSqlPpp.Utils.DbmsCommon hiding (selectRelation) 21> import Database.HsSqlPpp.Examples.Wrappers.SelectRelation 22> import qualified Database.HsSqlPpp.SqlTypes as Sql 23> import Database.HsSqlPpp.Catalog 24> import Database.HsSqlPpp.TypeChecker 25> import Database.HsSqlPpp.Parser 26> import Database.HsSqlPpp.Annotation 27> import Database.HsSqlPpp.Utils.Utils 28> 29> sqlQuery:: String -> String -> Q Exp 30> sqlQuery dbName sqlStr = do 31> (StatementHaskellType inA outA) <- liftStType 32> let cnName = mkName "cn" 33> argNames <- getNNewNames "a" $ length inA 34> lamE (map varP (cnName : argNames)) 35> [| selectRelation $(varE cnName) sqlStr 36> $(ListE <$> zipWithM toSqlIt argNames inA) >>= 37> return . map $(mapTupleFromSql $ map snd outA)|] 38> 39> where 40> liftStType :: Q StatementHaskellType 41> liftStType = runIO stType >>= (either (error . show) toH) 42> 43> stType :: IO (Either String StatementType) 44> stType = runErrorT $ do 45> cat <- getCat 46> tsl (getStatementType cat sqlStr) 47> 48> getCat :: ErrorT String IO Catalog 49> getCat = do 50> -- bad code to avoid reading the catalog multiple times 51> c1 <- liftIO $ readIORef globalCachedCatalog 52> case c1 of 53> Just c -> return c 54> Nothing -> do 55> c <- liftIO (readCatalogFromDatabase dbName) >>= 56> (tsl . updateCatalog defaultCatalog) 57> liftIO $ writeIORef globalCachedCatalog (Just c) 58> return c 59> 60> -- lambda which does [SqlValue] -> (T1, T2, ...) 61> mapTupleFromSql :: [Type] -> Q Exp 62> mapTupleFromSql outT = do 63> retNames <- getNNewNames "r" $ length outT 64> lamE [listP (map varP retNames)] 65> (tupE $ zipWith fromSqlIt retNames outT) 66> 67> toSqlIt :: Name -> Type -> Q Exp 68> toSqlIt n t = [| toSql $(castName n t)|] 69> 70> fromSqlIt :: Name -> Type -> Q Exp 71> fromSqlIt n t = do 72> n1 <- [| fromSql $(varE n) |] 73> cast n1 t 74> 75> cast :: Exp -> Type -> Q Exp 76> cast e = return . SigE e 77> 78> castName :: Name -> Type -> Q Exp 79> castName = cast . VarE 80> 81> getNNewNames :: String -> Int -> Q [Name] 82> getNNewNames i n = forM [1..n] $ const $ newName i 83 84 85evil hack to avoid reading the catalog from the database for each call 86to sqlStmt. Atm this means that you can only read the catalog from one 87database at compile time, but this should be an easy fix if too 88limiting. TODO: make this change, in case the catalog ends up being 89cached in ghci meaning if you change the database whilst developing in 90emacs it will go wrong 91 92> globalCachedCatalog :: IORef (Maybe Catalog) 93> {-# NOINLINE globalCachedCatalog #-} 94> globalCachedCatalog = unsafePerformIO (newIORef Nothing) 95 96------------------------------------------------------------------------------- 97 98sql parsing and typechecking 99---------------------------- 100 101This is the demonstration of using the type checker to get the 102information needed. 103 104Get the input and output types for a parameterized sql statement: 105 106> getStatementType :: Catalog -> String -> Either String StatementType 107> getStatementType cat sql = do 108> ast <- tsl $ parseSql "" sql 109> let (_,aast) = typeCheck cat ast 110> let a = getTopLevelInfos aast 111> return $ fromJust $ head a 112 113convert sql statement type to equivalent with sql types replaced with 114haskell equivalents - HDBC knows how to convert the actual values using 115toSql and fromSql as long as we add in the appropriate casts 116 117> data StatementHaskellType = StatementHaskellType [Type] [(String,Type)] 118> 119> toH :: StatementType -> Q StatementHaskellType 120> toH (StatementType i o) = do 121> ih <- mapM sqlTypeToHaskell i 122> oht <- mapM (sqlTypeToHaskell . snd) o 123> return $ StatementHaskellType ih $ zip (map fst o) oht 124> where 125> sqlTypeToHaskell :: Sql.Type -> TypeQ 126> sqlTypeToHaskell t = 127> case t of 128> Sql.ScalarType "text" -> [t| Maybe String |] 129> Sql.ScalarType "int4" -> [t| Maybe Int |] 130> Sql.ScalarType "int8" -> [t| Maybe Int |] 131> Sql.ScalarType "bool" -> [t| Maybe Bool |] 132> Sql.DomainType _ -> [t| Maybe String |] 133> x -> error $ show x