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

http://github.com/JakeWheat/hssqlppp · Haskell · 218 lines · 188 code · 30 blank · 0 comment · 7 complexity · 139f5b791dc84c72e43d2e4722d9aaf0 MD5 · raw file

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