parsing a set of strings

AlterTest.hs

{-# LANGUAGE ScopedTypeVariables, TupleSections #-}
module AlterTest where

import Data.Foldable
import Data.Tree
import qualified Data.Map.Strict as M
import Control.Monad
import qualified Text.ParserCombinators.ReadP as Parser
import Test.QuickCheck
import Data.List

pTest ::
    forall parser v.
    (MonadPlus parser)
    => (String -> parser ())
    -> [(String,v)]
    -> parser v
pTest string = msum . fmap (\(s,v) -> v <$ string s)

pTest2 ::
    forall parser v .
    (MonadPlus parser)
    => (String -> parser ())
    -> [(String,v)]
    -> parser v
pTest2 string = genParser string . compact

type Compact v = Forest (Either Char v)

compact :: forall v. [(String,v)] -> Compact v
compact [] = []
compact [("",v)] = [Node (Right v) []]
compact xs = map f . M.toAscList $ M.map compact m
  where
    m :: M.Map Char [(String,v)]
    m = M.fromListWith (++) $ map conv xs
    conv :: (String,v) -> (Char,[(String,v)])
    conv (y:ys,v) = (y,[(ys,v)])
    conv _ = error "compact: string set is ambiguous"
    f :: (Char, Compact v) -> Tree (Either Char v)
    f (c,t) = Node (Left c) t

genParser ::
    (Monad parser, MonadPlus parser)
    => (String -> parser ())
    -> Compact v -> parser v
genParser string = msum . fmap genParser'
  where
    genParser' (Node (Left c) fs) = string [c] >> genParser string fs
    genParser' (Node (Right v) []) = pure v
    genParser' _ = error "genParser: invalid Compact structure"

genStringSet :: Int -> Gen [String]
genStringSet 0 = pure [[]]
genStringSet maxLen = do
    endEarly <- choose (1,5 :: Int)
    if endEarly == 1
       then pure [[]]
       else do
           xs <- sublistOf ['a'..'f']
           let gen :: Char -> Gen [String]
               gen c = (fmap . fmap) (c:) (genStringSet (maxLen-1))
           concat <$> mapM gen xs

type ParserGen parser = ([(String,Int)] -> parser Int)

prop_Correctness
    :: ParserGen p
    -> ParserGen p
    -> (p Int -> String -> Maybe Int)
    -> Gen Property
prop_Correctness mkParser1 mkParser2 runParser = do
    ws <- genStringSet 5
    let tbl = zip ws [1 :: Int ..]
        p1 = mkParser1 tbl
        p2 = mkParser2 tbl
    rndTbl <- shuffle tbl
    pure (counterexample (intercalate "," ws)
          (all (\(inp,oup) ->
                runParser p1 inp == Just oup &&
                runParser p2 inp == Just oup) rndTbl))

main :: IO ()
main = do
    let genP1 = pTest (void . Parser.string)
        genP2 = pTest2 (void . Parser.string)
        runParser p = conv <$> Parser.readP_to_S (p <* Parser.eof)
        conv [(v,"")] = Just v
        conv _ = Nothing
    verboseCheck (prop_Correctness genP1 genP2 runParser)