Codegen.hs

-- | Modifications to the code generation used in Groundhog.
--
module TSN.Codegen (
  tsn_codegen_config,
  tsn_db_field_namer -- Used in a TSN.XML.News test.
  )
where

import Data.Char ( toUpper )
import Data.List.Utils ( join, split )
import Database.Groundhog.TH (
  CodegenConfig ( namingStyle ),
  NamingStyle ( mkDbFieldName, mkExprFieldName, mkExprSelectorName ),
  defaultCodegenConfig,
  lowerCaseSuffixNamingStyle )


strip_leading_underscore :: String -> String
strip_leading_underscore ('_' : rest) = rest
strip_leading_underscore s = s

-- | The lowercase naming style for database entities, provided by
--   Groundhog. Makes a better starting point than the default.
--
lowercase_ns :: NamingStyle
lowercase_ns = lowerCaseSuffixNamingStyle


-- | A database field name creator. It takes the field name (from a
--   record type) and drops the first component determined by
--   underscores. So, foo_bar_baz would get mapped to bar_baz in the
--   database.
--
--   Leading underscores are ignored, as those are used to hide unused
--   field warnings.
--
--   ==== __Examples__
--
--   >>> tsn_db_field_namer "herp" "derp" 0 "xml_player_name" 0
--   "player_name"
--
--   >>> tsn_db_field_namer "herp" "derp" 0 "db_player_name" 0
--   "player_name"
--
--   >>> tsn_db_field_namer "herp" "derp" 0 "_db_player_name" 0
--   "player_name"
--
tsn_db_field_namer :: String -> String -> Int -> String -> Int -> String
tsn_db_field_namer _ _ _ fieldname _ =
  (join "_") . tail . (split "_") $ strip_leading_underscore fieldname


-- | An expression field name creator. \"Expression\" in the context
--   of Groundhog means a constructor/type that you can use in queries
--   and update statement. We take the field name (from a record type)
--   as an argument and capitalize the first letter of each word.
--
--   Leading underscores are ignored, as those are used to hide unused
--   field warnings.
--
--   ==== __Examples__
--
--   >>> tsn_expr_field_namer "herp" "derp" 0 "foo_bar" 0
--   "Foo_Bar"
--
--   >>> tsn_expr_field_namer "herp" "derp" 0 "_foo_bar" 0
--   "Foo_Bar"
--
tsn_expr_field_namer :: String -> String -> Int -> String -> Int -> String
tsn_expr_field_namer _ _ _ fieldname _ =
  (join "_") . (map capitalize) . (split "_") $
    strip_leading_underscore fieldname
  where
    capitalize [] = []
    capitalize (c:cs) = (toUpper c : cs)


-- | An expression selector creator. This is needed for embedded
--   types, when Groundhog generates the stuff for it. The default is
--   almost OK, but if a field name has leading underscores, they're
--   left intact. The result is invalid. So, this strips them before
--   doing whatever the default implementation would do.
--
--   >>> tsn_expr_selector_namer "MyFoo" "MyBar" "_db_derp" 0
--   "Db_derpSelector"
--
tsn_expr_selector_namer :: String -> String -> String -> Int -> String
tsn_expr_selector_namer dn cn fn =
  the_default dn cn (strip_leading_underscore fn)
  where
    the_default = mkExprSelectorName lowercase_ns


-- | Combine the modifications above into a new naming style based on
--   the 'lowecase_ns'.
--
tsn_naming_style :: NamingStyle
tsn_naming_style =
  lowercase_ns { mkDbFieldName = tsn_db_field_namer,
                 mkExprFieldName = tsn_expr_field_namer,
                 mkExprSelectorName = tsn_expr_selector_namer }

-- | Create a 'CodegenConfig' by replacing the default 'namingStyle'
--   with our modified version.
--
tsn_codegen_config :: CodegenConfig
tsn_codegen_config =
  defaultCodegenConfig { namingStyle = tsn_naming_style }