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

  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