module IHP.NameSupport.Inflections
( pluralize
, singularize
, inflect
) where

import Prelude
import Data.Maybe (mapMaybe, fromMaybe, isJust, listToMaybe)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import System.IO.Unsafe (unsafePerformIO)
import IHP.NameSupport.Inflections.Data
import Text.Regex.PCRE.ByteString
import Text.Regex.PCRE.ByteString.Utils (substitute')

type RegexPattern = Text
type RegexReplace = Text
type Singular = Text
type Plural = Text

data Inflection
    = Simple (Singular, Plural)
    | Match (Maybe Regex, RegexReplace)

-- | pluralize a given word
-- >>> pluralize "person"
-- "people"
-- >>> pluralize "dog"
-- "dogs"
pluralize :: Text -> Text
pluralize :: Text -> Text
pluralize = [Inflection] -> Text -> Text
pluralizeWith [Inflection]
defaultPluralizeMapping

-- | default mappings for pluralization
defaultPluralizeMapping :: [Inflection]
defaultPluralizeMapping :: [Inflection]
defaultPluralizeMapping = [Inflection]
defaultPlurals [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultUncountables [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultIrregulars [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
irregularsPlural

-- | singularize a given word
-- >>> singularize "people"
-- "person"
-- >>> singularize "cats"
-- "cat"
singularize :: Text -> Text
singularize :: Text -> Text
singularize = [Inflection] -> Text -> Text
singularizeWith [Inflection]
defaultSingularizeMapping

-- | default mappings for singularization
defaultSingularizeMapping :: [Inflection]
defaultSingularizeMapping :: [Inflection]
defaultSingularizeMapping = [Inflection]
defaultSingulars [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultUncountables [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultIrregulars

-- | pluralize a word given a custom mapping.
-- Build the [Inflection] with a combination of
-- `makeUncountableMapping` `makeIrregularMapping` `makeMatchMapping`
pluralizeWith :: [Inflection] -> Text -> Text
pluralizeWith :: [Inflection] -> Text -> Text
pluralizeWith = (Text -> Inflection -> Maybe Text) -> [Inflection] -> Text -> Text
lookupWith Text -> Inflection -> Maybe Text
pluralLookup

-- | singularize a word given a custom mapping.
-- Build the [Inflection] with a combination of
-- `makeUncountableMapping` `makeIrregularMapping` `makeMatchMapping`
singularizeWith :: [Inflection] -> Text -> Text
singularizeWith :: [Inflection] -> Text -> Text
singularizeWith = (Text -> Inflection -> Maybe Text) -> [Inflection] -> Text -> Text
lookupWith Text -> Inflection -> Maybe Text
singularLookup

-- | inflect a word given any number
-- >>> inflect "person" 1
-- "person"
-- >>> inflect "person" 2
-- "people"
inflect :: Text -> Int -> Text
inflect :: Text -> Int -> Text
inflect Text
word Int
count = case Int
count of
    Int
1 -> Text -> Text
singularize Text
word
    Int
_ -> Text -> Text
pluralize Text
word

-- | inflect a word given any number and inflection mapping
inflectWith :: [Inflection] -> Text -> Int -> Text
inflectWith :: [Inflection] -> Text -> Int -> Text
inflectWith [Inflection]
inflections Text
text Int
count = case Int
count of
    Int
1 -> [Inflection] -> Text -> Text
singularizeWith [Inflection]
inflections Text
text
    Int
_ -> [Inflection] -> Text -> Text
pluralizeWith [Inflection]
inflections Text
text

lookupWith :: (Text -> Inflection -> Maybe Text) -> [Inflection] -> Text -> Text
lookupWith :: (Text -> Inflection -> Maybe Text) -> [Inflection] -> Text -> Text
lookupWith Text -> Inflection -> Maybe Text
f [Inflection]
mapping Text
target = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
target (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text]
matches
    where
        matches :: [Text]
matches = (Inflection -> Maybe Text) -> [Inflection] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Inflection -> Maybe Text
f Text
target) ([Inflection] -> [Inflection]
forall a. [a] -> [a]
reverse [Inflection]
mapping)

-- | Makes a simple list of mappings from singular to plural, e.g [("person", "people")]
-- the output of [Inflection] should be consumed by `singularizeWith` or `pluralizeWith`
makeMatchMapping :: [(RegexPattern, RegexReplace)] -> [Inflection]
makeMatchMapping :: [(Text, Text)] -> [Inflection]
makeMatchMapping = ((Text, Text) -> Inflection) -> [(Text, Text)] -> [Inflection]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
pattern, Text
replacement) -> (Maybe Regex, Text) -> Inflection
Match (Text -> Maybe Regex
regexPattern Text
pattern, Text
replacement))

-- | Makes a simple list of mappings from singular to plural, e.g [("person", "people")]
-- the output of [Inflection] should be consumed by `singularizeWith` or `pluralizeWith`
makeIrregularMapping :: [(Singular, Plural)] -> [Inflection]
makeIrregularMapping :: [(Text, Text)] -> [Inflection]
makeIrregularMapping = ((Text, Text) -> Inflection) -> [(Text, Text)] -> [Inflection]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Text) -> Inflection
Simple

-- | Makes a simple list of uncountables which don't have
-- singular plural versions, e.g ["fish", "money"]
-- the output of [Inflection] should be consumed by `singularizeWith` or `pluralizeWith`
makeUncountableMapping :: [Text] -> [Inflection]
makeUncountableMapping :: [Text] -> [Inflection]
makeUncountableMapping = (Text -> Inflection) -> [Text] -> [Inflection]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
text -> (Text, Text) -> Inflection
Simple (Text
text, Text
text))

defaultPlurals :: [Inflection]
defaultPlurals :: [Inflection]
defaultPlurals = [(Text, Text)] -> [Inflection]
makeMatchMapping [(Text, Text)]
defaultPlurals'

defaultSingulars :: [Inflection]
defaultSingulars :: [Inflection]
defaultSingulars = [(Text, Text)] -> [Inflection]
makeMatchMapping [(Text, Text)]
defaultSingulars'

defaultIrregulars :: [Inflection]
defaultIrregulars :: [Inflection]
defaultIrregulars = [(Text, Text)] -> [Inflection]
makeIrregularMapping [(Text, Text)]
defaultIrregulars'

defaultUncountables :: [Inflection]
defaultUncountables :: [Inflection]
defaultUncountables = [Text] -> [Inflection]
makeUncountableMapping [Text]
defaultUncountables'

-- Ensure That Words Such As 'people' Do Not Get Transformed Into 'peoples', As They Are Already Plural
irregularsPlural :: [Inflection]
irregularsPlural :: [Inflection]
irregularsPlural = [Text] -> [Inflection]
makeUncountableMapping ([Text] -> [Inflection]) -> [Text] -> [Inflection]
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Text) -> Text
forall a b. (a, b) -> b
snd [(Text, Text)]
defaultIrregulars'

pluralLookup :: Text -> Inflection -> Maybe Text
pluralLookup :: Text -> Inflection -> Maybe Text
pluralLookup Text
word (Match (Maybe Regex
pattern, Text
replacement)) = (Maybe Regex, Text) -> Text -> Maybe Text
runSubstitution (Maybe Regex
pattern, Text
replacement) Text
word
pluralLookup Text
word (Simple (Text
singular, Text
plural)) = if Text
word Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
singular then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
plural else Maybe Text
forall a. Maybe a
Nothing

singularLookup :: Text -> Inflection -> Maybe Text
singularLookup :: Text -> Inflection -> Maybe Text
singularLookup Text
word (Match (Maybe Regex
regex, Text
replacement)) = (Maybe Regex, Text) -> Text -> Maybe Text
runSubstitution (Maybe Regex
regex, Text
replacement) Text
word
singularLookup Text
word (Simple (Text
singular, Text
plural)) = if Text
word Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
plural then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
singular else Maybe Text
forall a. Maybe a
Nothing

runSubstitution :: (Maybe Regex, RegexReplace) -> Text -> Maybe Text
runSubstitution :: (Maybe Regex, Text) -> Text -> Maybe Text
runSubstitution (Maybe Regex
Nothing, Text
_) Text
_ = Maybe Text
forall a. Maybe a
Nothing
runSubstitution (Just Regex
regex, Text
replacement) Text
text = (Regex, Text) -> Text -> Maybe Text
matchWithReplace (Regex
regex, Text
replacement) Text
text

matchWithReplace :: (Regex, RegexReplace) -> Text -> Maybe Text
matchWithReplace :: (Regex, Text) -> Text -> Maybe Text
matchWithReplace (Regex
regex, Text
replacement) Text
text =
    if Text -> Regex -> Bool
regexMatch Text
text Regex
regex
        then Either String ByteString -> Maybe Text
forall {a}. Either a ByteString -> Maybe Text
toMaybe (Either String ByteString -> Maybe Text)
-> Either String ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Regex -> ByteString -> ByteString -> Either String ByteString
substitute' Regex
regex (Text -> ByteString
encodeUtf8 Text
text) (Text -> ByteString
encodeUtf8 Text
replacement)
        else Maybe Text
forall a. Maybe a
Nothing
    where
        toMaybe :: Either a ByteString -> Maybe Text
toMaybe = (a -> Maybe Text)
-> (ByteString -> Maybe Text) -> Either a ByteString -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> a -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (ByteString -> Text) -> ByteString -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8)

regexMatch :: Text -> Regex -> Bool
regexMatch :: Text -> Regex -> Bool
regexMatch Text
text Regex
regex = case Either WrapError (Maybe (Array Int (Int, Int)))
match of
    Left WrapError
_ -> Bool
False
    Right Maybe (Array Int (Int, Int))
m -> Maybe (Array Int (Int, Int)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Array Int (Int, Int))
m
    where
        match :: Either WrapError (Maybe (Array Int (Int, Int)))
match = IO (Either WrapError (Maybe (Array Int (Int, Int))))
-> Either WrapError (Maybe (Array Int (Int, Int)))
forall a. IO a -> a
unsafePerformIO (IO (Either WrapError (Maybe (Array Int (Int, Int))))
 -> Either WrapError (Maybe (Array Int (Int, Int))))
-> IO (Either WrapError (Maybe (Array Int (Int, Int))))
-> Either WrapError (Maybe (Array Int (Int, Int)))
forall a b. (a -> b) -> a -> b
$ Regex
-> ByteString
-> IO (Either WrapError (Maybe (Array Int (Int, Int))))
execute Regex
regex (Text -> ByteString
encodeUtf8 Text
text)

regexPattern :: Text -> Maybe Regex
regexPattern :: Text -> Maybe Regex
regexPattern Text
pattern = Either (Int, String) Regex -> Maybe Regex
forall {a} {a}. Either a a -> Maybe a
toMaybe Either (Int, String) Regex
regex
    where
        toMaybe :: Either a a -> Maybe a
toMaybe = (a -> Maybe a) -> (a -> Maybe a) -> Either a a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just
        regex :: Either (Int, String) Regex
regex = IO (Either (Int, String) Regex) -> Either (Int, String) Regex
forall a. IO a -> a
unsafePerformIO (IO (Either (Int, String) Regex) -> Either (Int, String) Regex)
-> IO (Either (Int, String) Regex) -> Either (Int, String) Regex
forall a b. (a -> b) -> a -> b
$ CompOption
-> ExecOption -> ByteString -> IO (Either (Int, String) Regex)
compile CompOption
compCaseless ExecOption
execBlank (ByteString -> IO (Either (Int, String) Regex))
-> ByteString -> IO (Either (Int, String) Regex)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
pattern