-- |
-- Module      :  Text.Countable
-- Copyright   :  © 2016 Brady Ouren
-- License     :  MIT
--
-- Maintainer  :  Brady Ouren <brady.ouren@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- pluralization and singularization transformations
--
-- Note: This library is portable in the sense of haskell extensions
-- however, it is _not_ portable in the sense of requiring PCRE regex
-- bindings on the system

{-# LANGUAGE OverloadedStrings #-}

module Text.Countable
  ( pluralize
  , pluralizeWith
  , singularize
  , singularizeWith
  , inflect
  , inflectWith
  , makeMatchMapping
  , makeIrregularMapping
  , makeUncountableMapping
  )
where

import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Text.Countable.Data
import Text.Regex.PCRE.ByteString
import Text.Regex.PCRE.ByteString.Utils (substitute')
import System.IO.Unsafe

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

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

-- | pluralize a word given a default mapping
pluralize :: Text -> Text
pluralize :: Text -> Text
pluralize = [Inflection] -> Text -> Text
pluralizeWith [Inflection]
mapping
  where
    mapping :: [Inflection]
mapping = [Inflection]
defaultIrregulars [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultUncountables [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultPlurals

-- | singularize a word given a default mapping
singularize :: Text -> Text
singularize :: Text -> Text
singularize = [Inflection] -> Text -> Text
singularizeWith [Inflection]
mapping
  where
    mapping :: [Inflection]
mapping = [Inflection]
defaultIrregulars [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultUncountables [Inflection] -> [Inflection] -> [Inflection]
forall a. [a] -> [a] -> [a]
++ [Inflection]
defaultSingulars

-- | 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 :: Text -> Int -> Text
inflect :: Text -> Int -> Text
inflect Text
t Int
i = case Int
i of
  Int
1 -> Text -> Text
singularize Text
t
  Int
_ -> Text -> Text
pluralize Text
t

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

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
headMaybe [Text]
matches
  where
    matches :: [Text]
matches = [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text]) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Inflection -> Maybe Text) -> [Inflection] -> [Maybe Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Inflection -> Maybe Text
f Text
target) ([Inflection] -> [Inflection]
forall a. [a] -> [a]
Prelude.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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
pat, Text
rep) -> (Maybe Regex, Text) -> Inflection
Match (Text -> Maybe Regex
regexPattern Text
pat, Text
rep))

-- | 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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
a -> (Text, Text) -> Inflection
Simple (Text
a,Text
a))


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'

pluralLookup :: Text -> Inflection -> Maybe Text
pluralLookup :: Text -> Inflection -> Maybe Text
pluralLookup Text
t (Match (Maybe Regex
r1,Text
r2)) = (Maybe Regex, Text) -> Text -> Maybe Text
runSub (Maybe Regex
r1,Text
r2) Text
t
pluralLookup Text
t (Simple (Text
a,Text
b)) = if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
a then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
b else Maybe Text
forall a. Maybe a
Nothing

singularLookup :: Text -> Inflection -> Maybe Text
singularLookup :: Text -> Inflection -> Maybe Text
singularLookup Text
t (Match (Maybe Regex
r1,Text
r2)) = (Maybe Regex, Text) -> Text -> Maybe Text
runSub (Maybe Regex
r1,Text
r2) Text
t
singularLookup Text
t (Simple (Text
a,Text
b)) = if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
b then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
a else Maybe Text
forall a. Maybe a
Nothing

runSub :: (Maybe Regex, RegexReplace) -> Text -> Maybe Text
runSub :: (Maybe Regex, Text) -> Text -> Maybe Text
runSub (Maybe Regex
Nothing, Text
_) Text
_ = Maybe Text
forall a. Maybe a
Nothing
runSub (Just Regex
reg, Text
rep) Text
t = (Regex, Text) -> Text -> Maybe Text
matchWithReplace (Regex
reg, Text
rep) Text
t

matchWithReplace :: (Regex, RegexReplace) -> Text -> Maybe Text
matchWithReplace :: (Regex, Text) -> Text -> Maybe Text
matchWithReplace (Regex
reg, Text
rep) Text
t =
  if Text -> Regex -> Bool
regexMatch Text
t Regex
reg
  then Either String ByteString -> Maybe Text
forall b. Either b 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
reg (Text -> ByteString
encodeUtf8 Text
t) (Text -> ByteString
encodeUtf8 Text
rep)
  else Maybe Text
forall a. Maybe a
Nothing
  where
    toMaybe :: Either b ByteString -> Maybe Text
toMaybe = (b -> Maybe Text)
-> (ByteString -> Maybe Text) -> Either b ByteString -> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> b -> 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
t Regex
r = 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
r (Text -> ByteString
encodeUtf8 Text
t)

regexPattern :: Text -> Maybe Regex
regexPattern :: Text -> Maybe Regex
regexPattern Text
pat = Either (Int, String) Regex -> Maybe Regex
forall b a. Either b a -> Maybe a
toMaybe Either (Int, String) Regex
reg
  where toMaybe :: Either b a -> Maybe a
toMaybe = (b -> Maybe a) -> (a -> Maybe a) -> Either b a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> b -> 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
        reg :: Either (Int, String) Regex
reg = 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 (Text -> ByteString
encodeUtf8 Text
pat)

headMaybe :: [a] -> Maybe a
headMaybe :: [a] -> Maybe a
headMaybe [] = Maybe a
forall a. Maybe a
Nothing
headMaybe (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x