{-# 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