haskelldb-th (empty) → 1.0

raw patch · 4 files changed

+326/−0 lines, 4 filesdep +basedep +haskelldbdep +mtlsetup-changed

Dependencies added: base, haskelldb, mtl, template-haskell

Files

• LICENSE +25/−0
• Setup.hs +4/−0
• haskelldb-th.cabal +27/−0
• src/Database/HaskellDB/CodeGen.hs +270/−0

@@ -0,0 +1,25 @@+Copyright (c) 2009, Justin Bailey+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice,+      this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice,+      this list of conditions and the following disclaimer in the documentation+      and/or other materials provided with the distribution.+    * The names of its contributors may be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain

@@ -0,0 +1,27 @@+Name: haskelldb-th+Version: 1.0+Cabal-version: >= 1.2+Build-type: Simple+Homepage: http://patch-tag.com/publicrepos/haskelldb-th+Copyright: The authors+Maintainer: jgbailey@gmail.com+Category: Database+License-File: LICENSE+Author: "Justin Bailey " <jgbailey@gmail.com>+License: BSD3+Synopsis: Template Haskell utilities for HaskellDB.+Description: +  Utility functions that make defining tables, fields, and queries in+  HaskellDB simpler.+  +Flag split-base++Library+  Build-depends: mtl+  Build-depends: base >= 3.0, haskelldb >= 0.11, template-haskell >= 2.2.0.0+  Extensions:+    TemplateHaskell+  Exposed-Modules:+        Database.HaskellDB.CodeGen+  Hs-source-dirs: src+  ghc-options: -O2

@@ -0,0 +1,270 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}
+{- |
+HaskellDB is a great library for writing type-safe SQL queries. That type safety
+comes with a significant boilerplate overhead, though. This library provides utilities
+that help reduce that boilerplate by generating the definitions, types and instances
+that HaskellDB expects to work with. It also provides some functions for building
+records for projections which otherwise can be quite cumbersome.
+-}
+module Database.HaskellDB.CodeGen (
+  -- * Field definition.
+  mkField, mkFieldWithName, mkDBDirectField,
+  -- * Table definition.
+  mkDBDirectTable, mkDBDirectTableWithName, mkDBDirectTableType
+  -- * Debugging utilities.
+  , printQ, Language.Haskell.TH.Ppr()
+  -- * Record creation (for projection).
+  , mkRecord)
+
+where
+
+import Database.HaskellDB (Attr, Expr, (<<), (!))
+import Database.HaskellDB.HDBRec (RecCons(..), RecNil(..), (#), FieldTag)
+import Database.HaskellDB.DBLayout (mkAttr, baseTable, hdbMakeEntry, Table, fieldName)
+
+import Data.Char (isUpper, isLower, toUpper, toLower)
+import Language.Haskell.TH 
+import qualified Language.Haskell.TH as TH
+
+-- | Creates a compile-time field declaration. The name given
+-- will be used to create the type and the name of the field returned. It
+-- will also be used to create a /field name/@Field@ function which
+-- can be used to place the field in a projection.
+--
+-- For example, @mkField \"fooBar\" [t|Int|]@ produces the following declarations:
+--
+-- > data FooBar = FooBar
+-- > instance FieldTag FooBar where fieldName _ = "fooBar"
+-- > fooBarField :: Attr FooBar Int
+-- > fooBarField = mkAttr FooBar
+--
+-- @mkField \"Bar_Foo\" [t|Bool|]@ would produce:
+--
+-- > data Bar_Foo = Bar_Foo
+-- > instance FieldTag Bar_Foo where fieldName _ = "bar_Foo"
+-- > bar_fooField :: Attr Bar_Foo Bool
+-- > bar_fooField = mkAttr Bar_Foo
+--
+mkField :: String -- ^ Name to base field 
+  -> TH.TypeQ -- ^ The type of the field.
+  -> Q [Dec]
+mkField [] t = error "Can't generate field from an empty string."
+mkField f@(c:cs) typ = 
+  let
+      fieldName = if isUpper c then f else (toUpper c) : cs
+      colName = if isLower c then f else (toLower c) : tail cs
+  in mkFieldWithName fieldName colName typ
+
+-- | Creates a compile time field declaration using the given
+-- arguments for the type and column name of the field. The @typN@ argument
+-- is used to produce the /field name/@Field@ function which can be used to
+-- add the field to a projection.
+--
+-- For example, @mkFieldWithName \"FooBar\" \"foo_bar\" [t|Int|]@ gives:
+--
+-- > data FooBar = FooBar
+-- > instance FieldTag FooBar where fieldName _ = "foo_bar"
+-- > fooBarField :: Attr FooBar Int
+-- > fooBarField = mkAttr FooBar
+--
+-- Note that an error will occur if @typN@ is not a proper type/constructor name.
+mkFieldWithName :: String -- ^ @typN@ - Name of the type representing the field. Must be a legal type name.
+  -> String -- ^ Column name for the field.
+  -> TH.TypeQ -- ^ Type of the field.
+  -> Q [Dec]
+mkFieldWithName [] _ _ = error "Can't create a field with no name."
+mkFieldWithName _ [] _ = error "Can't create a field with no column name."
+mkFieldWithName typN colName typeQ =
+  let attrF = (toLower (head typN) : tail typN) ++ "Field"
+  in mkFieldWithNameAndConstructor typN attrF colName typeQ
+
+-- | Creates necessary data and function declarations to represent
+-- the given field. Used internally by other make functions. All strings given must
+-- be legal, as they will not be transformed in any way.
+mkFieldWithNameAndConstructor :: String -- ^ Name of the type and constructor for this field. Must be a legal type name.
+  -> String -- ^ Name of the function which makes an attribute for this field (i.e, Attr <typeName> <fieldType>). Must be a legal function name.
+  -> String -- ^ Name of the column this field represents. Can be any string, though it should match the database column name.
+  -> TH.TypeQ -- ^ The type of the field.
+  -> Q [Dec]
+mkFieldWithNameAndConstructor typN attrF colName typeQ = do
+      colType <- typeQ
+      let typeName = mkName typN
+          attrName = mkName attrF
+          -- data declaration representing this field.
+          fieldD = DataD [] typeName [] [NormalC typeName []] []
+          -- instance declaration in FieldTag class for this field.
+          fieldI = InstanceD [] (AppT (ConT ''FieldTag)
+                                   (ConT typeName)) [FunD 'fieldName{-'-} [Clause [WildP]
+                                                      (NormalB (LitE (StringL colName))) []]]
+          -- Type signature for the function which creates an Attr value for the field.
+          fieldS = SigD attrName (AppT (AppT (ConT ''Attr) (ConT typeName)) colType)
+          -- actual function.
+          fieldF = ValD (VarP attrName) (NormalB (AppE (VarE 'mkAttr) --' 
+                                                              (ConE typeName))) []
+      return [fieldD, fieldI, fieldS, fieldF]
+
+-- | Creates a field definition in the style DBDirect uses. The @colName@
+-- argument is used to create the data definition, type synonym, and field function. The @typeQ@ argument specifies
+-- the type of the field. 
+--
+-- For example, @mkDBDirectField \"fooBar\" [t|Bool|]@ will produce:
+--
+-- > data FooBar = FooBar
+-- > instance FieldTag FooBar where fieldName _ = "fooBar"
+-- > fooBar :: Attr FooBar Bool
+-- > fooBar = mkAttr FooBar
+-- 
+mkDBDirectField :: String -- ^ @colName@ - column name. Will be used for a type and function name (with appropriate casing), so must be a legal name.
+  -> TH.TypeQ -- ^ @typeQ@ - The type of the field.
+  -> Q [Dec]
+mkDBDirectField colName typeQ =
+  let typeN = toUpper (head colName) : tail colName
+      attrN = toLower (head colName) : tail colName
+  in mkFieldWithNameAndConstructor typeN attrN colName typeQ
+
+-- | Creates definitions for a table and all its fields in the style of DBDirect.
+-- Takes a table name and a list of fields (as types). Generates
+-- a table type and a function to construct the table. The function
+-- will be the tablename in lower case. The type alias will
+-- be the table name with the first character capitalized.
+--
+-- For example:
+--
+-- > mkDBDirectTable "Table1" [("Col1", [t|Int|])
+-- >                          , ("Col2", [t|Bool|])]
+--
+-- Will produce
+--
+-- > type Table1 = (RecCons Col1 (Expr Int)
+-- >                (RecCons Col2 (Expr Bool)))
+-- > 
+-- > table1 :: Table Table1
+-- > table1 = baseTable "Table1" $
+-- >          hdbMakeEntry Col1 #
+-- >          hdbMakeEntry Col2
+-- >
+-- > data Col1 = Col1
+-- > instance FieldTag Col1 where fieldName _ = "col1"
+-- > col1 :: Attr Col1 Int
+-- > col1 = mkAttr Col1
+-- >
+-- > data Col2 = Col2
+-- > instance FieldTag Col2 where fieldName _ = "col2"
+-- > col2 :: Attr Col2 Int
+-- > col2 = mkAttr Col2
+-- 
+mkDBDirectTable :: String -- ^ Name of the table. Will be used to create the table type
+                   -- synonym and table creation function (with appropriate casing), so must be a
+                   -- legal name
+  -> [(String, TH.TypeQ)] -- Each pair is the field type (e.g., Bus_unit_id) and the type the field can hold (e.g., Int)
+  -> Q [Dec]
+mkDBDirectTable tbl f = mkDBDirectTableWithName tbl tbl f 
+
+-- | Creates definitions for a table and all its fields in the style of DBDirect.
+-- Takes a table name and a list of fields (as types). Generates
+-- a table type and a function to construct the table. The function
+-- will be the tablename in lower case. The type alias will
+-- be the table name with the first character capitalized. See "mkDBirectTable" for an example, as
+-- that function calls this one.
+mkDBDirectTableWithName :: String -- ^ Name of the table type to create. Will be cased properly but
+                                  -- must be a legal name.
+  -> String -- ^ Name of table to use in actual SQL generated. 
+  -> [(String, TH.TypeQ)] -- Each pair is the field type (e.g., Bus_unit_id) and the type the field can hold (e.g., Int).
+  -> Q [Dec]
+mkDBDirectTableWithName [] _ _= error "Can't create a table with no name."
+mkDBDirectTableWithName _ [] _= error "Can't create a table wiht no real name specified."
+mkDBDirectTableWithName _ _ [] = error "Can't create a table with no columns."
+mkDBDirectTableWithName tbl sqlTbl f = do
+  let fields = map (\(n, t) -> (mkName . capitalize $ n, t)) f -- make names of fields
+      -- Table type name
+      tblTN = mkName ((toUpper . head $ tbl) : tail tbl)
+      -- Table creation function name
+      tblFN = mkName ((toLower . head $ tbl) : tail tbl)
+      -- Get constructor name for each field 
+      fieldCons = map fst fields  
+      -- Build the type of the table from the fields given.
+      tblType = foldr (\(n,e) exp -> appT (appT (appT (conT ''RecCons) (conT n)) (appT (conT ''Expr) e)) exp) (conT ''RecNil) fields
+      capitalize (c:cs) = toUpper c : cs
+      capitalize cs = cs
+      lower (c:cs) = toLower c : cs
+      lower cs = cs
+      -- Builds the expression for creating each column in the table.
+      -- i.e., (hdbMakeEntry A # hdbMakeEntry B # ...)
+      tblCols :: [Name] -> ExpQ
+      tblCols (f:[]) =  appE [|hdbMakeEntry|] (conE f)
+      tblCols (f:fs) = appE (appE [|(#)|] (appE [|hdbMakeEntry|] (conE f))) (tblCols fs)
+      -- Body of the table creation function
+      tblBodyD = [| baseTable sqlTbl $(tblCols fieldCons)|]
+      -- Type signature for the table creation function
+      tblSigD = sigD tblFN (appT (conT ''Table) (conT tblTN))
+      -- Declaration of table creation function
+      tblConD = valD (varP tblFN) (normalB tblBodyD) []
+  -- Create the type synonmym representing for our table.
+  tblTypeD :: [Q Dec] <- do { ts <- mkDBDirectTableType (nameBase tblTN) fields; return $! map return ts; }
+  -- get field declarations. Ugliness due to mkDBDirectField returning Q [Dec]
+  fieldDecls :: [Q Dec] <- do { fs <- mapM (\(n, t) -> mkDBDirectField (lower . nameBase $ n) t) fields; return $! map return (concat fs) }
+  -- Return field and table declarations
+  sequence $ fieldDecls ++ tblTypeD ++ [tblSigD, tblConD]
+
+-- | Creates a type synonym for a table with the name given, using
+-- the list of fields given. See "mkDBDirectField" for an example, as that function
+-- calls this one to create the type signature.
+mkDBDirectTableType :: String -- ^ Name of the type synonym. Must be a legal name and properly cased.
+  -> [(Name, TH.TypeQ)] -- ^ List of fields in the table. Must be legal, properly cased fields.
+  -> Q [Dec] -- ^ The type synonym declaration.
+mkDBDirectTableType tblTN fields = do
+    -- Create the type synonmym representing for our table.
+    syn <- tySynD (mkName tblTN) [] tblType
+    return [syn]
+  where
+    -- Build the type of the table from the fields given.
+    tblType = foldr (\(n,e) exp -> appT (appT (appT (conT ''RecCons) (conT n)) (appT (conT ''Expr) e)) exp) (conT ''RecNil) fields
+
+
+{- | Create a record from the list of tables and fields given. The first
+ element of each tuple is a table. The second is a list of fields from
+ that table which will be in the new record. The record will be constructed
+ in the order of tables and fields given.
+
+ This is a Template Haskell function which must be spliced in and is
+ intended to use the @'@ (quote) facility for capturing names. An example:
+ 
+>  qry = do
+>    dtls <- pts_dlvry_order_dtls;
+>    status <- table pts_dlvry_status_v;
+>    restrict (status ! Pts_dlvry_status_v.pts_dlvry_order_dtl_id .==. dtls ! Pts_dlvry_order_dtl_v.pts_dlvry_order_dtl_id)
+>    project $(mkRecord [('dtls, ['Pts_dlvry_order_dtl_v.prt_desc
+>                         , 'Pts_dlvry_order_dtl_v.pts_dlvry_order_hdr_id
+>                         , 'Pts_dlvry_order_dtl_v.prt_id
+>                         , 'Pts_dlvry_order_dtl_v.pts_dlvry_order_dtl_id])
+>                       ,('status, ['Pts_dlvry_status_v.item_stat_nbr])])
+ 
+The type of qry is then
+
+>          (RecCons Pts_dlvry_order_dtl_v.Prt_desc (Expr (Maybe BStr40))
+>          (RecCons Pts_dlvry_order_dtl_v.Pts_dlvry_order_hdr_id (Expr (Maybe Int))
+>          (RecCons Pts_dlvry_order_dtl_v.Prt_id (Expr (Maybe BStr30))
+>          (RecCons Pts_dlvry_order_dtl_v.Pts_dlvry_order_dtl_id (Expr (Maybe Int))
+>          (RecCons Pts_dlvry_status_v.Item_stat_nbr (Expr (Maybe Int)) RecNil))))))
+
+If other fields need to be added to the record, they must come before the call
+to mkRecord:
+
+>    project $ filtered << someTable ! someField #
+>              $(mkRecord [('dtls, ['Pts_dlvry_order_dtl_v.prt_desc
+>                                    , 'Pts_dlvry_order_dtl_v.pts_dlvry_order_hdr_id
+>                                    , 'Pts_dlvry_order_dtl_v.prt_id
+>                                    , 'Pts_dlvry_order_dtl_v.pts_dlvry_order_dtl_id])
+>                          ,('status, ['Pts_dlvry_status_v.item_stat_nbr])])
+
+-}
+mkRecord :: [(TH.Name, [TH.Name])] -> ExpQ
+mkRecord = projTable . concatMap (\(table, fields) -> zip (repeat table) fields) 
+  where
+    projTable ([]) = [|id|]
+    projTable ((table, f):rest) = [|$(varE f) << $(varE table) ! $(varE f) # $(projTable rest)|]
+  
+-- | Prints a TH syntax declaration.
+printQ f = do
+  s <- runQ f
+  print s