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

  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