PermutationsSpec.hs

{-# LANGUAGE TypeFamilies #-}

module Control.Applicative.PermutationsSpec (spec) where

import Control.Applicative.Permutations
import Control.Monad
import Data.List
import Data.Void
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.Hspec.Megaparsec.AdHoc
import Test.QuickCheck
import Text.Megaparsec
import Text.Megaparsec.Char

spec :: Spec
spec = do
  describe "runPermutation & Permutation" $ do
    describe "Functor instance" $ do
      it "obeys identity law" $
        property $ \n ->
          prsp (fmap id (pure (n :: Int))) ""
            === prsp (id (pure n)) ""
      it "obeys composition law" $
        property $ \n m t ->
          let f = (+ m)
              g = (* t)
           in prs (fmap (f . g) (pure (n :: Int))) ""
                === prs ((fmap f . fmap g) (pure n)) ""
    describe "Applicative instance" $ do
      it "obeys identity law" $
        property $ \n ->
          prsp (pure id <*> pure (n :: Int)) ""
            === prsp (pure n) ""
      it "obeys composition law" $
        property $ \n m t ->
          let u = pure (+ m)
              v = pure (* t)
              w = pure (n :: Int)
           in prsp (pure (.) <*> u <*> v <*> w) ""
                === prsp (u <*> (v <*> w)) ""
      it "obeys homomorphism law" $
        property $ \x m ->
          let f = (+ m)
           in prsp (pure f <*> pure (x :: Int)) ""
                === prsp (pure (f x)) ""
      it "obeys interchange law" $
        property $ \n y ->
          let u = pure (+ n)
           in prsp (u <*> pure (y :: Int)) ""
                === prsp (pure ($ y) <*> u) ""
  describe "toPermutation" $
    it "works" $
      property $ \xs s' -> forAll (shuffle xs) $ \ys -> do
        let s = ys ++ s'
            p = foldr f (pure []) xs
            f x p' = (:) <$> toPermutation (char x) <*> p'
        prsp p s `shouldParse` xs
        prsp' p s `succeedsLeaving` s'
  describe "intercalateEffect" $
    it "works" $
      property $ \e xs s' ->
        let preconditions f =
              foldr1
                (.||.)
                [ -- Zero permutation targets will cause problems
                  property $ null xs,
                  -- If the effect is the prefix of the suffix, it will fail
                  not (null s') .&&. e == head s',
                  f
                ]
         in preconditions $
              forAll (intersperse e <$> shuffle xs) $ \ys -> do
                let s = ys ++ s'
                    p = intercalateEffect (char e) $ foldr f (pure []) xs
                    f x p' = (:) <$> toPermutation (char x) <*> p'
                prs p s `shouldParse` xs
                prs' p s `succeedsLeaving` s'
  describe "toPermutationWithDefault" $ do
    let testCases =
          [ ("abc", "abc", ""),
            ("acb", "abc", ""),
            ("bac", "abc", ""),
            ("bca", "abc", ""),
            ("cab", "abc", ""),
            ("cba", "abc", ""),
            ("aab", "ayz", "ab"),
            ("aba", "abz", "a"),
            ("baa", "abz", "a"),
            ("bba", "xbz", "ba"),
            ("bab", "abz", "b"),
            ("abb", "abz", "b"),
            ("cca", "xyc", "ca"),
            ("cac", "ayc", "c"),
            ("acc", "ayc", "c"),
            ("aaa", "ayz", "aa"),
            ("bbb", "xbz", "bb"),
            ("ccc", "xyc", "cc"),
            ("q", "xyz", "q"),
            ("", "xyz", "")
          ]
    forM_ testCases $ \(i, o, r) ->
      it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do
        prsp testPermParser i `shouldParse` o
        prsp' testPermParser i `succeedsLeaving` r
  describe "intercalateEffect (with default)" $ do
    let p = intercalateEffect (char ',') testPermParser
        testCases =
          [ ("a,b,c", "abc", ""),
            ("a,c,b", "abc", ""),
            ("b,a,c", "abc", ""),
            ("b,c,a", "abc", ""),
            ("c,a,b", "abc", ""),
            ("c,b,a", "abc", ""),
            ("aab", "ayz", "ab"),
            ("a,ba", "abz", "a"),
            ("b,aa", "abz", "a"),
            ("bba", "xbz", "ba"),
            ("b,ab", "abz", "b"),
            ("a,bb", "abz", "b"),
            ("cca", "xyc", "ca"),
            ("c,ac", "ayc", "c"),
            ("a,cc", "ayc", "c"),
            ("aaa", "ayz", "aa"),
            ("bbb", "xbz", "bb"),
            ("ccc", "xyc", "cc"),
            ("!", "xyz", "!"),
            (",", "xyz", ","),
            ("", "xyz", "")
          ]
    forM_ testCases $ \(i, o, r) ->
      it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do
        prs p i `shouldParse` o
        prs' p i `succeedsLeaving` r

prsp ::
  Permutation Parser a ->
  String ->
  Either (ParseErrorBundle String Void) a
prsp p = prs (runPermutation p)

prsp' ::
  Permutation Parser a ->
  String ->
  (State String Void, Either (ParseErrorBundle String Void) a)
prsp' p = prs' (runPermutation p)

testPermParser :: Permutation Parser String
testPermParser =
  f
    <$> toPermutationWithDefault 'x' (char 'a')
    <*> toPermutationWithDefault 'y' (char 'b')
    <*> toPermutationWithDefault 'z' (char 'c')
  where
    f a b c = [a, b, c]