{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Owoifier ( owoify
                , weakOwoify
                ) where

import qualified Data.Text as T

-- | String constant, text enclosed in this will not be owoified
owolessDelim :: T.Text
owolessDelim :: Text
owolessDelim = Text
"```"

-- | Maps f over every other element in a list:
-- e.g. `[f a, a, f a, a]`
alternate :: (a -> a) -> [a] -> [a]
alternate :: (a -> a) -> [a] -> [a]
alternate a -> a
f = ((a -> a) -> a -> a) -> [a -> a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
($) ([a -> a] -> [a -> a]
forall a. [a] -> [a]
cycle [a -> a
f, a -> a
forall a. a -> a
id])

-- | This takes a text and returns an owofied text
-- e.g. "North ```West```" -> "Nyowth ```West``` owo"
owoify :: T.Text -> T.Text
owoify :: Text -> Text
owoify Text
text = Text -> [Text] -> Text
T.intercalate Text
owolessDelim ((Text -> Text) -> [Text] -> [Text]
forall a. (a -> a) -> [a] -> [a]
alternate Text -> Text
owoifySegment [Text]
segments) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" owo"
    where segments :: [Text]
segments = Text -> Text -> [Text]
T.splitOn Text
owolessDelim Text
text

-- | Implements the weakOwoify over the segments of text
owoifySegment :: T.Text -> T.Text
owoifySegment :: Text -> Text
owoifySegment = Text -> Text
doInserts (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
weakOwoify

-- | Maps the function that actually owofies the text over each character of the string
weakOwoify :: T.Text -> T.Text
weakOwoify :: Text -> Text
weakOwoify = (Char -> Char) -> Text -> Text
T.map Char -> Char
owoifyChar

-- | Substitutes given characters for owoified variants in a string, otherwise `id`
owoifyChar :: Char -> Char
owoifyChar :: Char -> Char
owoifyChar Char
c
    | Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"LR" :: [Char]) = Char
'W'
    | Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"lr" :: [Char]) = Char
'w'
    | Bool
otherwise                 = Char
c

-- | Takes the cartesian product of two lists of chars and packs as a Text
-- e.g. "nmNM <-> "o" returns ["no", "mo", "No", "Mo"]
(<->) :: [Char] -> [Char] -> [T.Text]
<-> :: [Char] -> [Char] -> [Text]
(<->) [Char]
as [Char]
bs = [[Char] -> Text
T.pack [Char
a,Char
b] | Char
a <- [Char]
as, Char
b <- [Char]
bs]

-- | Checks if the y added should be lowercase
segmentsSmallY :: [T.Text]
segmentsSmallY :: [Text]
segmentsSmallY = [Char]
"NMnm" [Char] -> [Char] -> [Text]
<-> [Char]
"o" [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Char]
"nm" [Char] -> [Char] -> [Text]
<-> [Char]
"O"

-- | Checks if the y added should be uppercase
segmentsBigY :: [T.Text]
segmentsBigY :: [Text]
segmentsBigY = [Char]
"NM" [Char] -> [Char] -> [Text]
<-> [Char]
"O"

-- | Inserts the wanted symbol in between segments
mkRules :: [(Char, [T.Text])] -> [(T.Text, Char)]
mkRules :: [(Char, [Text])] -> [(Text, Char)]
mkRules [(Char, [Text])]
defs = do
    (Char
sym, [Text]
segments) <- [(Char, [Text])]
defs
    (, Char
sym) (Text -> (Text, Char)) -> [Text] -> [(Text, Char)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
segments

-- | Depending on what type of segment it is, it inserts a Y or y
insertionRules :: [(T.Text, Char)]
insertionRules :: [(Text, Char)]
insertionRules = [(Char, [Text])] -> [(Text, Char)]
mkRules
    [ (Char
'y', [Text]
segmentsSmallY)
    , (Char
'Y', [Text]
segmentsBigY)
    ]
-- | If it the word comes as a tuple with a Y then it is interpersed in the word and then replaces the og
applyRule :: (T.Text, Char) -> T.Text -> T.Text
applyRule :: (Text, Char) -> Text -> Text
applyRule (Text, Char)
rule
    = let (Text
word, Char
ins) = (Text, Char)
rule
          newWord :: Text
newWord     = Char -> Text -> Text
T.intersperse Char
ins Text
word in
    Text -> Text -> Text -> Text
T.replace Text
word Text
newWord

-- | Inserts the y-words in the text
doInserts :: T.Text -> T.Text
doInserts :: Text -> Text
doInserts Text
str = (Text -> (Text, Char) -> Text) -> Text -> [(Text, Char)] -> Text
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((Text, Char) -> Text -> Text) -> Text -> (Text, Char) -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text, Char) -> Text -> Text
applyRule) Text
str [(Text, Char)]
insertionRules