content: {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module Directory.BlockedWords where
  
  import Data.Char (isMark, isPunctuation, isSpace)
  import Data.List (isPrefixOf)
  import Data.Maybe (fromMaybe)
  import Data.Map.Strict (Map)
  import qualified Data.Map.Strict as M
  import Data.Set (Set)
  import qualified Data.Set as S
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.Normalize as TN
  
  data BlockedWordsConfig = BlockedWordsConfig
    { blockedWords :: Set Text,
      blockedFragments :: Set Text,
      extensionRules :: [(String, [String])],
      spelling :: Map Char [Char]
    }
  
  hasBlockedFragments :: BlockedWordsConfig -> Text -> Bool
  hasBlockedFragments BlockedWordsConfig {spelling, blockedFragments} s =
    any (\w -> any (`T.isInfixOf` w) blockedFragments) ws
    where
      ws = S.fromList $ filter (not . T.null) $ normalizeText spelling s
  
  hasBlockedWords :: BlockedWordsConfig -> Text -> Bool
  hasBlockedWords BlockedWordsConfig {spelling, blockedWords} s =
    not $ ws1 `S.disjoint` blockedWords && (length ws <= 1 || ws2 `S.disjoint` blockedWords)
    where
      ws = T.words s
      ws1 = normalizeWords ws
      ws2 = normalizeWords $ T.splitOn "  " s
      normalizeWords = S.fromList . filter (not . T.null) . concatMap (normalizeText spelling)
  
  normalizeText :: Map Char [Char] -> Text -> [Text]
  normalizeText spelling' =
    map (T.pack . filter (\c -> not $ isSpace c || isPunctuation c || isMark c))
      . allSubstitutions spelling'
      . removeTriples
      . T.unpack
      . T.toLower
      . TN.normalize TN.NFKD
  
  -- replaces triple and larger occurences with doubles
  removeTriples :: String -> String
  removeTriples xs = go xs '\0' False
    where
      go [] _ _ = []
      go (c : cs) prev samePrev
        | prev /= c = c : go cs c False
        | samePrev = go cs c True
        | otherwise = c : go cs c True
  
  -- Generate all possible strings by substituting each character
  allSubstitutions :: Map Char [Char] -> String -> [String]
  allSubstitutions spelling' = sequence . map substs
    where
      substs c = fromMaybe [c] $ M.lookup c spelling'
  
  wordVariants :: [(String, [String])] -> String -> [Text]
  wordVariants [] s = [T.pack s]
  wordVariants (sub : subs) s = concatMap (wordVariants subs) (replace sub)
    where
      replace (pat, tos) = go s
        where
          go [] = [""]
          go s'@(c : rest)
            | pat `isPrefixOf` s' =
                let s'' = drop (length pat) s'
                    restVariants = go s''
                in map (pat <>) restVariants
                     <> concatMap (\to -> map (to <>) restVariants) tos
            | otherwise = map (c :) (go rest)
  