/src-extra/tosort/examples/wrappers/GenerateTupleWrapper.lhs
Haskell | 220 lines | 185 code | 35 blank | 0 comment | 4 complexity | 4f58c1881226a3b05dc827c6ad6af402 MD5 | raw file
Possible License(s): BSD-3-Clause
1Code isn't finished, shouldn't be too difficult to sort it out, but 2seems a bit pointless when the th version works nice. 3 4> {-# LANGUAGE FlexibleContexts #-} 5 6> module Database.HsSqlPpp.Examples.Wrappers.GenerateTupleWrapper 7> (wrapperGen) where 8 9> import Language.Haskell.Exts hiding (String) 10> import qualified Language.Haskell.Exts as Exts 11> import Data.Generics.PlateData 12> import Data.Generics hiding (Prefix,Infix) 13> import Control.Monad.Error 14> import Data.Maybe 15 16> import Database.HsSqlPpp.SqlTypes as Sql 17> import Database.HsSqlPpp.Catalog 18> import Database.HsSqlPpp.TypeChecker 19> import Database.HsSqlPpp.Parser 20> import Database.HsSqlPpp.Annotation 21 22 23 24> wrapperGen :: String -- ^ name of database to typecheck against 25> -> FilePath -- ^ haskell source filename to process 26> -> IO String -- ^ generated wrapper source code 27> wrapperGen db fn = do 28> p <- parseFile fn 29> case p of 30> ParseOk ast -> do 31> catU <- readCatalogFromDatabase db 32> case updateCatalog defaultCatalog catU of 33> Left er -> return $ show er 34> Right cat -> 35> return $ {-ppShow ast ++ "\n\n" ++ -} prettyPrint (processTree cat (addImports ast)) 36> x -> return $ show x 37 38This is the function which finds the statements which look like 39ident = "string" 40and converts them into hdbc wrappers with the correct types 41 42> processTree :: Data a => Catalog -> a -> a 43> processTree cat = 44> transformBi $ \x -> 45> case x of 46> (PatBind _ 47> (PVar (Ident fnName)) 48> Nothing 49> (UnGuardedRhs(Lit (Exts.String sqlSrc))) 50> (BDecls [])) : tl 51> -> createWrapper cat fnName sqlSrc ++ tl 52> x1 -> x1 53 54for each bind to convert, lookup the haskell types needed, then 55create a type sig and a function to use hdbc to run the sql 56 57> createWrapper :: Catalog 58> -> String 59> -> String 60> -> [Decl] 61> createWrapper cat fnName sql = 62> let rt = getStatementType cat sql 63> in case rt of 64> Left e -> error e 65> Right (StatementType pt ts) -> 66> let pts = map sqlTypeToHaskellTypeName pt 67> tns = map (sqlTypeToHaskellTypeName . snd) ts 68> in [makeTypeSig fnName pts tns 69> ,makeFn fnName sql pts tns] 70 71================================================================================ 72 73create the type signature for a wrapper, produces something like 74(IConnection conn) => conn -> inarg1 -> inarg2 -> ... -> 75 IO [(outarg1, outarg2, ...)] 76 77> makeTypeSig :: String -> [String] -> [String] -> Decl 78> makeTypeSig fnName argTypes typeNames = 79> TypeSig noSrcLoc [Ident fnName] $ 80> TyForall Nothing [ClassA (UnQual (Ident "IConnection")) [TyVar(Ident "conn")]] $ 81> foldr TyFun lastArg args 82> where 83> tc = TyCon . UnQual . Ident 84> tntt = (TyApp (tc "Maybe")) . tc 85> args = ((TyVar (Ident "conn")) : map tntt argTypes) 86> lastArg = (TyApp (tc "IO") (TyList (TyTuple Boxed $ map tntt typeNames))) 87 88================================================================================ 89 90create the function which calls hdbc 91 92takes something like: 93pieces_at_pos = "select * from pieces where x = ? and y = ?;" 94and produces: 95 96pieces_at_pos conn b0 b1 97 = do r <- selectRelation conn 98 "select * from pieces where x = ? and y = ?;" 99 [toSql b0, toSql b1] 100 return $ 101 flip map r $ 102 \ [a0, a1, a2, a3, a4] -> 103 (fromSql a0, fromSql a1, fromSql a2, fromSql a3, fromSql a4) 104 105doesn't really need to know the types, just the number of inargs and outargs, 106since the work is done by hdbc's toSql and fromSql, and by the type signature 107that is generated in the function above 108 109> makeFn :: String -> String -> [String] -> [String] -> Decl 110> makeFn fnName sql pts typeNames = FunBind 111> [ Match noSrcLoc( 112> Ident fnName ) 113> (PVar (Ident "conn") : map (PVar . Ident) pNames) 114> Nothing ( 115> UnGuardedRhs ( 116> Do 117> [ Generator noSrcLoc ( 118> PVar ( Ident "r" ) ) ( 119> App ( 120> App ( 121> App ( 122> Var ( UnQual ( Ident "selectRelation" ) ) ) ( 123> Var ( UnQual ( Ident "conn" ) ) ) ) ( 124> Lit ( Exts.String sql ) ) ) ( 125> List $ map (\l -> App ( 126> Var ( UnQual ( Ident "toSql" ) ) ) ( 127> Var ( UnQual ( Ident l ) ) )) pNames 128> )) 129> , Qualifier ( 130> InfixApp ( 131> Var ( UnQual ( Ident "return" ) ) ) ( 132> QVarOp ( UnQual ( Symbol "$" ) ) ) ( 133> InfixApp ( 134> App ( 135> App ( 136> Var ( UnQual ( Ident "flip" ) ) ) ( 137> Var ( UnQual ( Ident "map" ) ) ) ) ( 138> Var ( UnQual ( Ident "r" ) ) ) ) ( 139> QVarOp ( UnQual ( Symbol "$" ) ) ) ( 140> Lambda noSrcLoc 141> [ PList (map (PVar . Ident) vns) 142> ] ( 143> Tuple (map (\n -> App (vui "fromSql") (vui n)) vns) 144> ) ) ) ) 145> ] ) ) ( 146> BDecls [] ) 147> ] 148> where 149> varName n = "a" ++ show n 150> vns = map varName [0..length typeNames - 1] 151> vui = Var . UnQual . Ident 152> pName n = "b" ++ show n 153> pNames = map pName [0..length pts - 1] 154 155================================================================================ 156 157> addImports :: Data a => a -> a 158> addImports = 159> transformBi $ \x -> 160> case x of 161> Module sl mn o wt es im d -> Module sl mn o wt es (imports ++ im) d 162 163> imports :: [ImportDecl] 164> imports = [ImportDecl {importLoc = noSrcLoc 165> ,importModule = ModuleName "Database.HDBC" 166> ,importQualified = False 167> ,importSrc = False 168> ,importPkg = Nothing 169> ,importAs = Nothing 170> ,importSpecs = Nothing 171> } 172> ,ImportDecl {importLoc = noSrcLoc 173> ,importModule = ModuleName "Database.HsSqlPpp.Dbms.WrapLib" 174> ,importQualified = False 175> ,importSrc = False 176> ,importPkg = Nothing 177> ,importAs = Nothing 178> ,importSpecs = Nothing 179> }] 180 181================================================================================ 182 183parsing and typechecking 184 185get the input and output types for a parameterized sql statement: 186 187> getStatementType :: Catalog -> String -> Either String StatementType 188> getStatementType cat sql = do 189> ast <- tsl $ parseSql "" sql 190> let (_,aast) = typeCheck cat ast 191> let a = getTopLevelInfos aast 192> return $ fromJust $ head a 193 194return the equivalent haskell type for a sql type as a string 195 196> sqlTypeToHaskellTypeName :: Sql.Type -> String 197> sqlTypeToHaskellTypeName t = 198> case t of 199> ScalarType "text" -> "String" 200> ScalarType "int4" -> "Int" 201> ScalarType "int8" -> "Int" 202> ScalarType "bool" -> "Bool" 203> DomainType _ -> "String" 204> x -> show x 205 206================================================================================ 207 208simple ast shortcuts 209 210> noSrcLoc :: SrcLoc 211> noSrcLoc = (SrcLoc "" 0 0) 212 213================================================================================ 214 215error utility - convert either to ErrorT String 216 217> tsl :: (MonadError String m, Show t) => Either t a -> m a 218> tsl x = case x of 219> Left s -> throwError $ show s 220> Right b -> return b