src/TSN/Codegen.hs

   1 -- | Modifications to the code generation used in Groundhog.
   2 --
   3 module TSN.Codegen (
   4   tsn_codegen_config,
   5   tsn_db_field_namer -- Used in a TSN.XML.News test.
   6   )
   7 where
   8
   9 import Data.Char ( toUpper )
  10 import Data.List.Utils ( join, split )
  11 import Database.Groundhog.TH (
  12   CodegenConfig ( namingStyle ),
  13   NamingStyle ( mkDbFieldName, mkExprFieldName ),
  14   defaultCodegenConfig,
  15   lowerCaseSuffixNamingStyle )
  16
  17
  18 -- | The lowercase naming style for database entities, provided by
  19 --   Groundhog. Makes a better starting point than the default.
  20 --
  21 lowercase_ns :: NamingStyle
  22 lowercase_ns = lowerCaseSuffixNamingStyle
  23
  24
  25 -- | A database field name creator. It takes the field name (from a
  26 --   record type) and drops the first component determined by
  27 --   underscores. So, foo_bar_baz would get mapped to bar_baz in the
  28 --   database.
  29 --
  30 --   Examples:
  31 --
  32 --   >>> tsn_db_field_namer "herp" "derp" 0 "xml_player_name" 0
  33 --   "player_name"
  34 --
  35 tsn_db_field_namer :: String -> String -> Int -> String -> Int -> String
  36 tsn_db_field_namer _ _ _ fieldname _ =
  37   (join "_") . tail . (split "_") $ fieldname
  38
  39
  40 -- | An expression field name creator. \"Expression\" in the context
  41 --   of Groundhog means a constructor/type that you can use in queries
  42 --   and update statement. We take the field name (from a record type)
  43 --   as an argument and capitalize the first letter of each word.
  44 --
  45 --   Examples:
  46 --
  47 --   >>> tsn_expr_field_namer "herp" "derp" 0 "foo_bar" 0
  48 --   "Foo_Bar"
  49 --
  50 tsn_expr_field_namer :: String -> String -> Int -> String -> Int -> String
  51 tsn_expr_field_namer _ _ _ fieldname _ =
  52   (join "_") . (map capitalize) . (split "_") $ fieldname
  53   where
  54     capitalize [] = []
  55     capitalize (c:cs) = (toUpper c : cs)
  56
  57
  58 -- | Combine the modifications above into a new naming style based on
  59 --   the 'lowecase_ns'.
  60 --
  61 tsn_naming_style :: NamingStyle
  62 tsn_naming_style = lowercase_ns { mkDbFieldName = tsn_db_field_namer,
  63                                   mkExprFieldName = tsn_expr_field_namer }
  64
  65 -- | Create a 'CodegenConfig' by replacing the default 'namingStyle'
  66 --   with our modified version.
  67 --
  68 tsn_codegen_config :: CodegenConfig
  69 tsn_codegen_config =
  70   defaultCodegenConfig { namingStyle = tsn_naming_style }