{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Interpreter.StringConversion -- Copyright : (c) OleksandrZhabenko 2021-2023 -- License : MIT -- Stability : Experimental -- Maintainer : oleksandr.zhabenko@yahoo.com -- -- A library that has commonly used function for the phonetic-languages implementations. module Interpreter.StringConversion where import GHC.Base import GHC.Num ((-),(+),abs) import Text.Read (readMaybe) import Text.Show import Data.Maybe (fromJust,fromMaybe) import Data.Char (isDigit) import Data.List import Data.Monoid (mappend) import Control.Exception import System.IO {-| Converts the second given string into the form that can be easily used by the phonetic-languages-simplified-* implementations. -} convStringInterpreter :: String -> String -> String convStringInterpreter contrs xs | null contrs = xs | null . words $ xs = xs | case filter (\y -> isDigit y || y == '/' || y == '-') contrs of { a:'/':bs -> a /= '/' && a /= '0' ; '1':'0':'/':cs -> True ; ~rrr -> False } = let ys = filter (\y -> isDigit y || y == '/' || y == '-') contrs in case ys of ~a:'/':bs -> let wordsN = words xs wordN = min (fromMaybe 1 (readMaybe [a]::Maybe Int)) (length wordsN) pos = fromMaybe 0 (readMaybe bs::Maybe Int) wrdP = wordsN !! (wordN - 1) (ts,us) | pos >= 0 = splitAt pos wrdP | otherwise = splitAt (length wrdP + pos) wrdP twoWords = ts `mappend` (' ':us) (wss,tss) = splitAt (wordN - 1) wordsN kss = drop 1 tss in if null wss then twoWords `mappend` (' ':unwords kss) else unwords wss `mappend` (' ':twoWords) `mappend` (' ':unwords kss) '1':'0':'/':bs -> let wordsN = words xs wordN = min 10 (length wordsN) pos = fromMaybe 0 (readMaybe bs::Maybe Int) wrdP = wordsN !! (min 9 (length wordsN - 1)) (ts,us) | pos >= 0 = splitAt pos wrdP | otherwise = splitAt (length wrdP + pos) wrdP twoWords = ts `mappend` (' ':us) (wss,tss) = splitAt 9 wordsN kss = drop 1 tss in unwords wss `mappend` (' ':twoWords) | length (filter (\t -> if (length . words $ xs) >= 10 then t >= '1' && t <= '9' else t >= '1' && [t] <= show (length . words $ xs)) $ contrs) < 2 = xs -- The following case is changed since the version 0.6.0.0 to support concatenations of the arbitrary two words, not needed to be consequent ones. | otherwise = let cntrs = (if take 1 (filter isDigit contrs) == "0" then "0" else []) `mappend` (filter (\t -> if (length . words $ xs) >= 10 then t >= '0' && t <= '9' else t >= '1' && [t] <= show (length . words $ xs)) $ contrs) tss = words xs in case length cntrs of 2 -> if take 1 cntrs == "0" then xs else let pos = fromJust (readMaybe (take 1 cntrs)::Maybe Int) number = fromJust (readMaybe (drop 1 cntrs)::Maybe Int) (zss,yss) = splitAt (pos - 1) tss (kss,lss) = splitAt number yss in if length tss < pos + number - 1 then xs else if null zss then concat kss `mappend` " " `mappend` unwords lss else unwords zss `mappend` " " `mappend` concat kss `mappend` " " `mappend` unwords lss _ -> let idxs = map (\x -> let k = fromJust (readMaybe [x]::Maybe Int) in if k == 0 then 10 else k) $ (if take 1 cntrs == "0" then drop 1 cntrs else cntrs) wordsN = map (\i -> tss !! (i - 1)) idxs restWords = tss \\ wordsN in unwords restWords `mappend` " " `mappend` concat wordsN {-| Variant of the 'convStringInterpreter' with the additional possibility to correct splitting after revision. -} convStringInterpreterIO :: String -> String -> IO String convStringInterpreterIO contrs xs | null contrs = return xs | null . words $ xs = return xs | case filter (\y -> isDigit y || y == '/' || y == '-') contrs of { a:'/':bs -> a /= '/' && a /= '0' ; '1':'0':'/':cs -> True ; ~rrr -> False } = let ys = filter (\y -> isDigit y || y == '/' || y == '-') contrs in case ys of ~a:'/':bs -> do let wordsN = words xs wordN = min (fromMaybe 1 (readMaybe [a]::Maybe Int)) (length wordsN) pos = fromMaybe 0 (readMaybe bs::Maybe Int) wrdP = wordsN !! (wordN - 1) if abs pos >= 8 then do corr pos wrdP >>= \pos2 -> correctionF pos2 wrdP wordN wordsN else correctionF pos wrdP wordN wordsN '1':'0':'/':bs -> do let wordsN = words xs wordN = min 10 (length wordsN) pos = fromMaybe 0 (readMaybe bs::Maybe Int) wrdP = wordsN !! (min 9 (length wordsN - 1)) if abs pos >= 8 then do corr pos wrdP >>= \pos2 -> correctionF pos2 wrdP wordN wordsN else correctionF pos wrdP wordN wordsN | length (filter (\t -> if (length . words $ xs) >= 10 then t >= '1' && t <= '9' else t >= '1' && [t] <= show (length . words $ xs)) $ contrs) < 2 = return xs | otherwise = let cntrs = (if take 1 (filter isDigit contrs) == "0" then "0" else []) `mappend` (filter (\t -> if (length . words $ xs) >= 10 then t >= '0' && t <= '9' else t >= '1' && [t] <= show (length . words $ xs)) $ contrs) tss = words xs in case length cntrs of 2 -> if take 1 cntrs == "0" then return xs else do let pos = fromJust (readMaybe (take 1 cntrs)::Maybe Int) number = fromJust (readMaybe (drop 1 cntrs)::Maybe Int) (zss,yss) = splitAt (pos - 1) tss (kss,lss) = splitAt number yss if length tss < pos + number - 1 then return xs else if null zss then return (concat kss `mappend` " " `mappend` unwords lss) else return (unwords zss `mappend` " " `mappend` concat kss `mappend` " " `mappend` unwords lss) _ -> let idxs = map (\x -> let k = fromJust (readMaybe [x]::Maybe Int) in if k == 0 then 10 else k) $ (if take 1 cntrs == "0" then drop 1 cntrs else cntrs) wordsN = map (\i -> tss !! (i - 1)) idxs restWords = tss \\ wordsN in return (unwords restWords `mappend` " " `mappend` concat wordsN) corr :: Int -> String -> IO Int corr pos wrdP = do let (ts, us) | pos >= 0 = splitAt pos wrdP | otherwise = splitAt (length wrdP + pos) wrdP twoWords = ts `mappend` (' ':us) putStrLn $ "?: " `mappend` twoWords llls <- getLine if null llls then return pos else do let tss = words llls wrd0 = fromMaybe 1 (readMaybe (concat . take 1 $ tss)::Maybe Int) posN = fromMaybe 0 (readMaybe (concat . drop 1 . take 2 $ tss)::Maybe Int) case wrd0 of 1 -> corr (pos - posN) wrdP 2 -> corr (pos + posN) wrdP _ -> corr pos wrdP correctionF :: Monad m => Int -> String -> Int -> [String] -> m String correctionF pos wrdP wordN wordsN = do let (ts,us) | pos >= 0 = splitAt pos wrdP | otherwise = splitAt (length wrdP + pos) wrdP twoWords = ts `mappend` (' ':us) (wss,tss) = splitAt (wordN - 1) wordsN kss = drop 1 tss if null wss then return (twoWords `mappend` (' ':unwords kss)) else return (unwords wss `mappend` (' ':twoWords) `mappend` (' ':unwords kss)) {-| Inspired by: 'https://hackage.haskell.org/package/base-4.15.0.0/docs/src/GHC-IO.html#catch' Reads a textual file given by its 'FilePath' and returns its contents lazily. If there is some 'IOException' thrown or an empty file then returns just "". Raises an exception for the binary file. -} readFileIfAny :: FilePath -> IO String readFileIfAny file = catch (readFile file) (\(e :: IOException) -> return "") ------------------------------------------------------------- argsConvertTextual :: String -> [String] -> [String] argsConvertTextual ts tss | any (== ts) tss = tss | otherwise = tss `mappend` [ts] {-# INLINE argsConvertTextual #-} fullArgsConvertTextual :: (String -> Bool) -- ^ The predicate that checks whether the given argument is not a phonetic language word in the representation. -> String -> String -> [String] -> [String] fullArgsConvertTextual p textProcessment0 lineA args = argsConvertTextual textProcessment0 (takeWhile p args `mappend` words lineA) {-# INLINE fullArgsConvertTextual #-} ------------------------------------------------------------- fullArgsConvertTextualSimple :: (String -> Bool) -- ^ The predicate that checks whether the given argument is not a phonetic language word in the representation. -> String -> [String] -> [String] fullArgsConvertTextualSimple p lineA args = takeWhile p args `mappend` words lineA {-# INLINE fullArgsConvertTextualSimple #-}