src/TSN/Codegen.hs

   1 module TSN.Codegen (
   2   tsn_codegen_config,
   3   tsn_db_field_namer -- Used in a TSN.XML.News test.
   4   )
   5 where
   6
   7 import Data.Char ( toLower, toUpper )
   8 import Data.List.Utils ( join, split )
   9 import Database.Groundhog.TH (
  10   CodegenConfig ( namingStyle ),
  11   NamingStyle ( mkDbConstrName, mkDbFieldName, mkExprFieldName ),
  12   defaultCodegenConfig )
  13
  14 default_ns :: NamingStyle
  15 default_ns = namingStyle defaultCodegenConfig
  16
  17 -- | A database field name creator. It takes the field name (from a
  18 --   record type) and drops the first component determined by
  19 --   underscores. So, foo_bar_baz would get mapped to bar_baz in the
  20 --   database.
  21 tsn_db_field_namer :: String -> String -> Int -> String -> Int -> String
  22 tsn_db_field_namer _ _ _ fieldname _ =
  23   (join "_") . tail . (split "_") $ fieldname
  24
  25 tsn_db_constr_namer :: String -> String -> Int -> String
  26 tsn_db_constr_namer _ constrname _ =
  27   map toLower constrname
  28
  29 tsn_expr_field_namer :: String -> String -> Int -> String -> Int -> String
  30 tsn_expr_field_namer _ _ _ fieldname _ =
  31   (join "_") . (map capitalize) . (split "_") $ fieldname
  32   where
  33     capitalize [] = []
  34     capitalize (c:cs) = (toUpper c : cs)
  35
  36 tsn_naming_style :: NamingStyle
  37 tsn_naming_style = default_ns { mkDbConstrName = tsn_db_constr_namer,
  38                                 mkDbFieldName = tsn_db_field_namer,
  39                                 mkExprFieldName = tsn_expr_field_namer }
  40
  41 tsn_codegen_config :: CodegenConfig
  42 tsn_codegen_config =
  43   defaultCodegenConfig { namingStyle = tsn_naming_style }