content: -----------------------------------------------------------
  -- |
  -- Module      :  Query
  -- Copyright   :  HWT Group (c) 2003, dp03-7@mdstud.chalmers.se
  -- License     :  BSD-style
  -- 
  -- Maintainer  :  dp03-7@mdstud.chalmers.se
  -- Stability   :  experimental
  -- Portability :  non-portable (requires Template Haskell)
  --
  -- Provides a Template Haskell function that declares
  -- a HaskellDB field.
  -- 
  -- $Revision: 1.2 $
  -----------------------------------------------------------
  module THField (field, module Database.HaskellDB.DBLayout) where
  
  import Database.HaskellDB.DBLayout
  import Language.Haskell.THSyntax
  
  -- | Declare a field.
  field :: String  -- ^ Haskell identifier for the field (e.g. "xid")
        -> String  -- ^ Actual field name (e.g. "id")
        -> String  -- ^ Name of the field label type (e.g. "Id")
        -> Bool    -- ^ Whether the field is nullable
        -> String  -- ^ Name of the value type of the field (e.g. "Int")
        -> Q [Dec]
  field attrName fieldName tagName nullable typeName 
      = return $ mkField attrName fieldName tagName nullable typeName 
  
  mkField :: String -> String -> String -> Bool -> String -> [Dec]
  mkField attrName fieldName tagName nullable typeName = 
      [
       mkTag tagName, 
       mkFieldTagInstance tagName fieldName, 
       mkAttrSig attrName tagName nullable typeName, 
       mkAttrVal attrName tagName
      ]
  
  mkTag tagName = DataD [] tagName [] [NormalC tagName []] []
  
  mkFieldTagInstance tagName fieldName = 
      InstanceD [] (AppT (ConT "FieldTag") (ConT tagName)) 
  		  [FunD "fieldName" 
  		   [Clause [WildP] (NormalB (LitE (StringL fieldName))) []]]
  
  mkAttrSig attrName tagName nullable typeName 
      = SigD attrName (AppT (AppT 
  			   (ConT "Attr") 
  			   (ConT tagName)) (mkType nullable typeName))
  
  mkType nullable typeName = if nullable then AppT (ConT "Maybe") t else t
      where t = ConT typeName
  
  mkAttrVal attrName tagName = 
      ValD (VarP attrName) (NormalB 
  			  (AppE (VarE "mkAttr") 
  			   (ConE tagName))) []
  
  