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 ),
  defaultCodegenConfig,
  lowerCaseSuffixNamingStyle )


-- | 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.
--
--   Examples:
--
--   >>> tsn_db_field_namer "herp" "derp" 0 "xml_player_name" 0
--   "player_name"
--
tsn_db_field_namer :: String -> String -> Int -> String -> Int -> String
tsn_db_field_namer _ _ _ fieldname _ =
  (join "_") . tail . (split "_") $ 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.
--
--   Examples:
--
--   >>> 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 "_") $ fieldname
  where
    capitalize [] = []
    capitalize (c:cs) = (toUpper c : cs)


-- | 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 }

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