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, mkExprSelectorName ),
  14   defaultCodegenConfig,
  15   lowerCaseSuffixNamingStyle )
  16
  17
  18 strip_leading_underscore :: String -> String
  19 strip_leading_underscore ('_' : rest) = rest
  20 strip_leading_underscore s = s
  21
  22 -- | The lowercase naming style for database entities, provided by
  23 --   Groundhog. Makes a better starting point than the default.
  24 --
  25 lowercase_ns :: NamingStyle
  26 lowercase_ns = lowerCaseSuffixNamingStyle
  27
  28
  29 -- | A database field name creator. It takes the field name (from a
  30 --   record type) and drops the first component determined by
  31 --   underscores. So, foo_bar_baz would get mapped to bar_baz in the
  32 --   database.
  33 --
  34 --   Leading underscores are ignored, as those are used to hide unused
  35 --   field warnings.
  36 --
  37 --   ==== __Examples__
  38 --
  39 --   >>> tsn_db_field_namer "herp" "derp" 0 "xml_player_name" 0
  40 --   "player_name"
  41 --
  42 --   >>> tsn_db_field_namer "herp" "derp" 0 "db_player_name" 0
  43 --   "player_name"
  44 --
  45 --   >>> tsn_db_field_namer "herp" "derp" 0 "_db_player_name" 0
  46 --   "player_name"
  47 --
  48 tsn_db_field_namer :: String -> String -> Int -> String -> Int -> String
  49 tsn_db_field_namer _ _ _ fieldname _ =
  50   (join "_") . tail . (split "_") $ strip_leading_underscore fieldname
  51
  52
  53 -- | An expression field name creator. \"Expression\" in the context
  54 --   of Groundhog means a constructor/type that you can use in queries
  55 --   and update statement. We take the field name (from a record type)
  56 --   as an argument and capitalize the first letter of each word.
  57 --
  58 --   Leading underscores are ignored, as those are used to hide unused
  59 --   field warnings.
  60 --
  61 --   ==== __Examples__
  62 --
  63 --   >>> tsn_expr_field_namer "herp" "derp" 0 "foo_bar" 0
  64 --   "Foo_Bar"
  65 --
  66 --   >>> tsn_expr_field_namer "herp" "derp" 0 "_foo_bar" 0
  67 --   "Foo_Bar"
  68 --
  69 tsn_expr_field_namer :: String -> String -> Int -> String -> Int -> String
  70 tsn_expr_field_namer _ _ _ fieldname _ =
  71   (join "_") . (map capitalize) . (split "_") $
  72     strip_leading_underscore fieldname
  73   where
  74     capitalize [] = []
  75     capitalize (c:cs) = (toUpper c : cs)
  76
  77
  78 -- | An expression selector creator. This is needed for embedded
  79 --   types, when Groundhog generates the stuff for it. The default is
  80 --   almost OK, but if a field name has leading underscores, they're
  81 --   left intact. The result is invalid. So, this strips them before
  82 --   doing whatever the default implementation would do.
  83 --
  84 --   >>> tsn_expr_selector_namer "MyFoo" "MyBar" "_db_derp" 0
  85 --   "Db_derpSelector"
  86 --
  87 tsn_expr_selector_namer :: String -> String -> String -> Int -> String
  88 tsn_expr_selector_namer dn cn fn fp =
  89   the_default dn cn (strip_leading_underscore fn) fp
  90   where
  91     the_default = mkExprSelectorName lowercase_ns
  92
  93
  94 -- | Combine the modifications above into a new naming style based on
  95 --   the 'lowecase_ns'.
  96 --
  97 tsn_naming_style :: NamingStyle
  98 tsn_naming_style =
  99   lowercase_ns { mkDbFieldName = tsn_db_field_namer,
 100                  mkExprFieldName = tsn_expr_field_namer,
 101                  mkExprSelectorName = tsn_expr_selector_namer }
 102
 103 -- | Create a 'CodegenConfig' by replacing the default 'namingStyle'
 104 --   with our modified version.
 105 --
 106 tsn_codegen_config :: CodegenConfig
 107 tsn_codegen_config =
 108   defaultCodegenConfig { namingStyle = tsn_naming_style }