adblock2privoxy-3.0.0: src/ParserExtTests.hs

module ParserExtTests
  ( testParsecExt,
    testParseMorse,
    encodeMorse,
  )
where

import Control.Applicative hiding (many)
import Control.Monad.State
import Data.List
import Data.Maybe
import ParsecExt
import Text.ParserCombinators.Parsec hiding (State, (<|>))
import Utils

---------------------------------------------------------------------------------------------
------------------------- parsec ext usage samples ------------------------------------------
---------------------------------------------------------------------------------------------

type ExampleCase = ([String], String, String)

parsersChain :: [StringStateParser ExampleCase]
parsersChain = square3 prefix mid suffix
  where -- all parsers except for last one should consume some input and give some output
    prefix = manyCases ((: []) <$> (string "ab" <|> string "zz"))
    mid = many1Cases $ (: []) <$> letter -- list of letters
    suffix = many1Cases $ try $ many1 alphaNum

testParsecExt :: Either ParseError [([String], String, String)]
testParsecExt = parse (cases parsersChain <* string "$$") "x" "abebz12$$"

testParseMorse :: Either ParseError [String]
testParseMorse = parseMorse "......-...-..---"

--------------------------------------------------------------------------------
--- Morse chars parsing: parse "......-...-..---" in all possible ways ---------
--------------------------------------------------------------------------------

morseChars :: [(String, Char)]
morseChars =
  [ (".-", 'A'),
    ("-...", 'B'),
    ("-.-.", 'C'),
    ("-..", 'D'),
    (".", 'E'),
    ("..-.", 'F'),
    ("--.", 'G'),
    ("....", 'H'),
    ("..", 'I'),
    (".---", 'J'),
    ("-.-", 'K'),
    (".-..", 'L'),
    ("--", 'M'),
    ("-.", 'N'),
    ("---", 'O'),
    (".--.", 'P'),
    ("--.-", 'Q'),
    (".-.", 'R'),
    ("...", 'S'),
    ("-", 'T'),
    ("..-", 'U'),
    ("...-", 'V'),
    (".--", 'W'),
    ("-..-", 'X'),
    ("-.--", 'Y'),
    ("--..", 'Z'),
    ("-----", '0'),
    (".----", '1'),
    ("..---", '2'),
    ("...--", '3'),
    ("....-", '4'),
    (".....", '5'),
    ("-....", '6'),
    ("--...", '7'),
    ("---..", '8'),
    ("----.", '9')
  ]

morseCharCodes :: [String]
morseCharCodes = fst <$> morseChars

-- HELLO = "......-...-..---"
encodeMorse :: String -> String
encodeMorse s = fst =<< mapMaybe code s
  where
    code c = find (\pair -> snd pair == c) morseChars

decodeMorse :: [String] -> String
decodeMorse ss = snd <$> mapMaybe code ss
  where
    code s = find (\pair -> fst pair == s) morseChars

-- find possibilites to continue from a given prefix
findMorseSteps :: String -> [String] -> [String]
findMorseSteps prefix codes = case find (== prefix) codes of
  Nothing -> case filter (isPrefixOf prefix) codes of
    [] -> []
    filtered ->
      findMorseSteps (prefix ++ ".") filtered
        ++ findMorseSteps (prefix ++ "-") filtered
  Just match -> [match]

morseStepParser :: [String] -> Parser String
morseStepParser [] = pzero
morseStepParser [step] = string step
morseStepParser (step : steps') = string step <|> morseStepParser steps'

morseParser :: Int -> StringStateParser (ZipListM String)
morseParser pos = do
  acc' <- get
  let acc = fromMaybe "" acc'
      candidates = filter (\x -> isPrefixOf acc x && acc /= x) morseCharCodes
      steps = drop (length acc) <$> findMorseSteps acc candidates
      parser = morseStepParser steps
  res <- lift parser
  put (Just $ acc ++ res)
  return (zipListM $ replicate pos "" ++ (res : repeat ""))

morseParsers :: [StringStateParser (ZipListM String)]
morseParsers = repeat morseParser <*> [0 ..]

parseMorse :: String -> Either ParseError [String]
parseMorse s = fmap postProcess <$> parseMorseRaw "x" s
  where
    parseMorseRaw = parse (cases morseParsers)
    postProcess = decodeMorse . toLists
    toLists = takeWhile (not . null) . getZipListM