{-|
Module: IHP.NameSupport
Description:  Transforms names, e.g. table names to model names
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.NameSupport
( tableNameToModelName
, columnNameToFieldName
, modelNameToTableName
, humanize
, ucfirst
, lcfirst
, fieldNameToColumnName
, escapeHaskellKeyword
, tableNameToControllerName
, tableNameToViewName
, enumValueToControllerName
, toSlug
, module IHP.NameSupport.Inflections
, fieldNameToFieldLabel
, columnNameToFieldLabel
, removeIdSuffix
) where

import Prelude hiding (splitAt, words, map)
import IHP.HaskellSupport
import Data.Text
import Data.String.Conversions (cs)
import qualified Data.Char as Char
import qualified Text.Inflections as Inflector
import qualified Data.Maybe as Maybe
import qualified Data.List as List
import Control.Monad (join)
import IHP.NameSupport.Inflections
import qualified Text.Inflections
import qualified Data.Text as Text

-- | Transforms a underscore table name to a camel case model name.
--
-- >>> tableNameToModelName "users"
-- "User"
--
-- >>> tableNameToModelName "projects"
-- "Project"
tableNameToModelName :: Text -> Text
tableNameToModelName :: Text -> Text
tableNameToModelName Text
"brain_waves" = Text
"BrainWave"
tableNameToModelName Text
tableName = do
    let singularizedTableName :: Text
singularizedTableName = Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text
singularize Text
tableName)
    if Text
"_" Text -> Text -> Bool
`isInfixOf` Text
singularizedTableName
        then Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall {a} {a} {b}. (Show a, Show a) => a -> Either a b -> b
unwrapEither Text
tableName (Either (ParseErrorBundle Text Void) Text -> Text)
-> Either (ParseErrorBundle Text Void) Text -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toCamelCased Bool
True (Text -> Either (ParseErrorBundle Text Void) Text)
-> Text -> Either (ParseErrorBundle Text Void) Text
forall a b. (a -> b) -> a -> b
$ Text
singularizedTableName
        else Text -> Text
ucfirst Text
singularizedTableName
{-# INLINABLE tableNameToModelName #-}

-- | Transforms a underscore table name to a name for a controller
--
-- >>> tableNameToControllerName "users"
-- "Users"
--
-- >>> tableNameToControllerName "projects"
-- "Projects"
--
-- >>> tableNameToControllerName "user_projects"
-- "UserProjects"
tableNameToControllerName :: Text -> Text
tableNameToControllerName :: Text -> Text
tableNameToControllerName Text
tableName = do
    if Text
"_" Text -> Text -> Bool
`isInfixOf` Text
tableName
        then Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall {a} {a} {b}. (Show a, Show a) => a -> Either a b -> b
unwrapEither Text
tableName (Either (ParseErrorBundle Text Void) Text -> Text)
-> Either (ParseErrorBundle Text Void) Text -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toCamelCased Bool
True Text
tableName
        else Text -> Text
ucfirst Text
tableName
{-# INLINABLE tableNameToControllerName #-}

-- | Transforms an underscore table name to a name for a view
--
-- >>> tableNameToViewName "users"
--
-- >>> tableNameToViewName "projects"
--
-- >>> tableNameToViewName "user_projects"
tableNameToViewName :: Text -> Text
tableNameToViewName :: Text -> Text
tableNameToViewName = Text -> Text
tableNameToControllerName
{-# INLINABLE tableNameToViewName #-}

-- | Transforms a enum value to a name for a model
--
-- >>> enumValueToControllerName "happy"
-- "Happy"
--
-- >>> enumValueToControllerName "very happy"
-- "VeryHappy"
--
-- >>> enumValueToControllerName "very_happy"
-- "VeryHappy"
enumValueToControllerName :: Text -> Text
enumValueToControllerName :: Text -> Text
enumValueToControllerName Text
enumValue =
    let
        words :: [Inflector.SomeWord]
        words :: [SomeWord]
words =
                Text
enumValue
                Text -> (Text -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
" "
                [Text]
-> ([Text] -> [Either (ParseErrorBundle Text Void) [SomeWord]])
-> [Either (ParseErrorBundle Text Void) [SomeWord]]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Either (ParseErrorBundle Text Void) [SomeWord])
-> [Text] -> [Either (ParseErrorBundle Text Void) [SomeWord]]
forall a b. (a -> b) -> [a] -> [b]
List.map ([Word 'Acronym]
-> Text -> Either (ParseErrorBundle Text Void) [SomeWord]
forall (f :: * -> *).
(Foldable f, Functor f) =>
f (Word 'Acronym)
-> Text -> Either (ParseErrorBundle Text Void) [SomeWord]
Inflector.parseSnakeCase [])
                [Either (ParseErrorBundle Text Void) [SomeWord]]
-> ([Either (ParseErrorBundle Text Void) [SomeWord]]
    -> [[SomeWord]])
-> [[SomeWord]]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Either (ParseErrorBundle Text Void) [SomeWord] -> [SomeWord])
-> [Either (ParseErrorBundle Text Void) [SomeWord]] -> [[SomeWord]]
forall a b. (a -> b) -> [a] -> [b]
List.map (\case
                        Left ParseErrorBundle Text Void
failed -> String -> [SomeWord]
forall a. HasCallStack => String -> a
error (String -> String
forall a b. ConvertibleStrings a b => a -> b
cs (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"enumValueToControllerName failed for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseErrorBundle Text Void -> String
forall a. Show a => a -> String
show ParseErrorBundle Text Void
failed)
                        Right [SomeWord]
result -> [SomeWord]
result)
                [[SomeWord]] -> ([[SomeWord]] -> [SomeWord]) -> [SomeWord]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [[SomeWord]] -> [SomeWord]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
    in
        Bool -> [SomeWord] -> Text
Inflector.camelizeCustom Bool
True [SomeWord]
words

-- | Transforms a camel case model name to a underscored table name.
--
-- >>> modelNameToTableName "User"
-- "users"
--
-- >>> modelNameToTableName "UserProject"
-- "user_projects"
modelNameToTableName :: Text -> Text
modelNameToTableName :: Text -> Text
modelNameToTableName Text
modelName =
        Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toUnderscore Text
modelName
        Either (ParseErrorBundle Text Void) Text
-> (Either (ParseErrorBundle Text Void) Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall {a} {a} {b}. (Show a, Show a) => a -> Either a b -> b
unwrapEither Text
modelName
        Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text
pluralize
{-# INLINABLE modelNameToTableName #-}

-- | Transforms a underscore table column name to a camel case attribute name for use in haskell.
--
-- >>> columnNameToFieldName "email"
-- "email"
--
-- >>> columnNameToFieldName "project_id"
-- "projectId"
columnNameToFieldName :: Text -> Text
columnNameToFieldName :: Text -> Text
columnNameToFieldName Text
columnName = Text -> Text
escapeHaskellKeyword (Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall {a} {a} {b}. (Show a, Show a) => a -> Either a b -> b
unwrapEither Text
columnName (Either (ParseErrorBundle Text Void) Text -> Text)
-> Either (ParseErrorBundle Text Void) Text -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toCamelCased Bool
False Text
columnName)
{-# INLINABLE columnNameToFieldName #-}

{-# INLINABLE unwrapEither #-}
unwrapEither :: a -> Either a b -> b
unwrapEither a
_ (Right b
value) = b
value
unwrapEither a
input (Left a
value) = String -> b
forall a. HasCallStack => String -> a
error (String
"IHP.NameSupport: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
value String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (value to be transformed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>  a -> String
forall a. Show a => a -> String
show a
input String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")")

-- | Transforms a camel case attribute name from haskell to a underscore table column name for the database.
--
-- >>> fieldNameToColumnName "email"
-- "email"
--
-- >>> fieldNameToColumnName "projectId"
-- "project_id"
fieldNameToColumnName :: Text -> Text
fieldNameToColumnName :: Text -> Text
fieldNameToColumnName Text
columnName = Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall {a} {a} {b}. (Show a, Show a) => a -> Either a b -> b
unwrapEither Text
columnName (Either (ParseErrorBundle Text Void) Text -> Text)
-> Either (ParseErrorBundle Text Void) Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toUnderscore Text
columnName
{-# INLINABLE fieldNameToColumnName #-}

-- | Returns a more friendly version for an identifier
humanize :: Text -> Text
humanize :: Text -> Text
humanize Text
text = Text -> Either (ParseErrorBundle Text Void) Text -> Text
forall {a} {a} {b}. (Show a, Show a) => a -> Either a b -> b
unwrapEither Text
text (Either (ParseErrorBundle Text Void) Text -> Text)
-> Either (ParseErrorBundle Text Void) Text -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> Either (ParseErrorBundle Text Void) Text
Inflector.toHumanized Bool
True Text
text
{-# INLINABLE humanize #-}

{-# INLINABLE applyFirst #-}
applyFirst :: (Text -> Text) -> Text -> Text
applyFirst :: (Text -> Text) -> Text -> Text
applyFirst Text -> Text
f Text
text =
    let (Text
first, Text
rest) = Int -> Text -> (Text, Text)
splitAt Int
1 Text
text
    in (Text -> Text
f Text
first) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest

-- | Make a text's first character lowercase
--
-- >>> lcfirst "Hello World"
-- "hello World"
--
-- >>> lcfirst "alread lowercase"
-- "already lowercase"
lcfirst :: Text -> Text
lcfirst :: Text -> Text
lcfirst = (Text -> Text) -> Text -> Text
applyFirst Text -> Text
toLower
{-# INLINABLE lcfirst #-}

-- | Make a text's first character uppercase
--
-- >>> ucfirst "hello world"
-- "Hello World"
--
-- >>> ucfirst "Already uppercase"
-- "Already uppercase"
ucfirst :: Text -> Text
ucfirst :: Text -> Text
ucfirst = (Text -> Text) -> Text -> Text
applyFirst Text -> Text
toUpper
{-# INLINABLE ucfirst #-}

-- | Add '_' to the end of a name if it is a reserved haskell keyword
--
-- >>> escapeHaskellKeyword "test"
-- "test"
--
-- >>> escapeHaskellKeyword "type"
-- "type_"
escapeHaskellKeyword :: Text -> Text
escapeHaskellKeyword :: Text -> Text
escapeHaskellKeyword Text
name = if Text -> Text
toLower Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Text]
haskellKeywords then Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" else Text
name

haskellKeywords :: [Text]
haskellKeywords :: [Text]
haskellKeywords = [ Text
"_"
    , Text
"as"
    , Text
"case"
    , Text
"class"
    , Text
"data"
    , Text
"default"
    , Text
"deriving"
    , Text
"do"
    , Text
"else"
    , Text
"hiding"
    , Text
"if"
    , Text
"import"
    , Text
"in"
    , Text
"infix"
    , Text
"infixl"
    , Text
"infixr"
    , Text
"instance"
    , Text
"let"
    , Text
"module"
    , Text
"newtype"
    , Text
"of"
    , Text
"qualified"
    , Text
"then"
    , Text
"type"
    , Text
"where"
    , Text
"forall"
    , Text
"mdo"
    , Text
"family"
    , Text
"role"
    , Text
"pattern"
    , Text
"static"
    , Text
"group"
    , Text
"by"
    , Text
"using"
    , Text
"foreign"
    , Text
"export"
    , Text
"label"
    , Text
"dynamic"
    , Text
"safe"
    , Text
"interruptible"
    , Text
"unsafe"
    , Text
"stdcall"
    , Text
"ccall"
    , Text
"capi"
    , Text
"prim"
    , Text
"javascript"
    , Text
"rec"
    , Text
"proc"
    ]

-- | Transforms a string to a value to be safely used in urls
--
-- >>> toSlug "IHP Release: 21.08.2020 (v21082020)"
-- "ihp-release-21-08-2020-v21082020"
--
-- >>> toSlug "Hallo! @ Welt"
-- "hallo-welt"
toSlug :: Text -> Text
toSlug :: Text -> Text
toSlug Text
text =
        Text
text
        Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> Text
toLower
        Text -> (Text -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Char -> Char) -> Text -> Text
map Char -> Char
replaceChar
        Text -> (Text -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> [Text]
words
        [Text] -> ([Text] -> Text) -> Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> [Text] -> Text
intercalate Text
"-"
    where
        replaceChar :: Char -> Char
replaceChar Char
'ä' = Char
'a'
        replaceChar Char
'ö' = Char
'o'
        replaceChar Char
'ü' = Char
'u'
        replaceChar Char
char = if Char -> Bool
Char.isAlphaNum Char
char Bool -> Bool -> Bool
&& Char -> Bool
Char.isAscii Char
char then Char
char else Char
' '


-- | Transform a data-field name like @userName@  to a friendly human-readable name like @User name@
--
-- >>> fieldNameToFieldLabel "userName"
-- "User name"
--
fieldNameToFieldLabel :: Text -> Text
fieldNameToFieldLabel :: Text -> Text
fieldNameToFieldLabel Text
fieldName = Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (let (Right [SomeWord]
parts) = [Word 'Acronym]
-> Text -> Either (ParseErrorBundle Text Void) [SomeWord]
forall (f :: * -> *).
(Foldable f, Functor f) =>
f (Word 'Acronym)
-> Text -> Either (ParseErrorBundle Text Void) [SomeWord]
Text.Inflections.parseCamelCase [] Text
fieldName in [SomeWord] -> Text
Text.Inflections.titleize [SomeWord]
parts)
{-# INLINABLE fieldNameToFieldLabel #-}

-- | Transform a column name like @user_name@  to a friendly human-readable name like @User name@
--
-- >>> columnNameToFieldLabel "user_name"
-- "User name"
--
columnNameToFieldLabel :: Text -> Text
columnNameToFieldLabel :: Text -> Text
columnNameToFieldLabel Text
columnName = Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (let (Right [SomeWord]
parts) = [Word 'Acronym]
-> Text -> Either (ParseErrorBundle Text Void) [SomeWord]
forall (f :: * -> *).
(Foldable f, Functor f) =>
f (Word 'Acronym)
-> Text -> Either (ParseErrorBundle Text Void) [SomeWord]
Text.Inflections.parseSnakeCase [] Text
columnName in [SomeWord] -> Text
Text.Inflections.titleize [SomeWord]
parts)
{-# INLINABLE columnNameToFieldLabel #-}


-- | Removes @ Id@  from a string
--
-- >>> removeIdSuffix "User Id"
-- "User"
--
-- When the string does not end with @ Id@, it will just return the input string:
--
-- >>> removeIdSuffix "Project"
-- "Project"
removeIdSuffix :: Text -> Text
removeIdSuffix :: Text -> Text
removeIdSuffix Text
text = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
text (Text -> Text -> Maybe Text
Text.stripSuffix Text
" Id" Text
text)
{-# INLINABLE removeIdSuffix #-}