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