/src-extra/tosort/examples/wrappers/ThTupleWrapper.lhs

  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