CataSpec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-- GHC 7.10 seems to require KindSignatures for the polymorph folds defined
-- below.
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE KindSignatures #-}
#endif

module Data.Morphism.CataSpec (main, spec) where

import Test.Hspec
import Data.Morphism.Cata

import Data.Bool (bool)
import Data.Maybe (maybe)
import Data.Either (either)

data Unit = Unit
data Binary = Zero | One
data PolymorphSum a = PolymorphSum a
data PolymorphProduct a b = PolymorphProduct a b
data RegularRecursive a = Cons a (RegularRecursive a) | Empty

$(makeCata defaultOptions ''Unit)
$(makeCata defaultOptions ''Binary)
$(makeCata defaultOptions ''PolymorphSum)
$(makeCata defaultOptions ''PolymorphProduct)
$(makeCata defaultOptions ''RegularRecursive)
$(makeCata defaultOptions { cataName = "binaryFold" } ''Binary)

$(makeCata defaultOptions { cataName = "bool'" } ''Bool)
$(makeCata defaultOptions { cataName = "maybe'" } ''Maybe)
$(makeCata defaultOptions { cataName = "either'" } ''Either)
$(makeCata defaultOptions { cataName = "foldr'" } ''[])

-- `main` is here so that this module can be run from GHCi on its own.  It is
-- not needed for automatic spec discovery.
main :: IO ()
main = hspec spec

spec :: Spec
spec = do
  describe "type support" $ do
    it "handles Unit" $ do
      unit True Unit `shouldBe` True
      unit "foo" Unit `shouldBe` "foo"

    it "handles simple sum types" $ do
      binary 'z' 'o' Zero `shouldBe` 'z'
      binary 'z' 'o' One `shouldBe` 'o'

    it "handles polymorph sum types" $ do
      polymorphSum show (PolymorphSum True) `shouldBe` "True"
      polymorphSum length (PolymorphSum "Frerich") `shouldBe` 7

    it "handles polymorph product types" $ do
      let fn = (\b x -> show (if b then x + 1 else x - 1)) :: Bool -> Int -> String
      polymorphProduct fn (PolymorphProduct True 99) `shouldBe` "100"
      polymorphProduct fn (PolymorphProduct False 88) `shouldBe` "87"

    it "handles regular recursive types" $ do
      let length' = regularRecursive (\_ acc -> acc + 1) 0 :: RegularRecursive a -> Int
      length' Empty `shouldBe` 0
      length' (Cons () (Cons () (Cons () Empty))) `shouldBe` 3
      length' (Cons 'a' (Cons 'b' Empty)) `shouldBe` 2

  describe "custom options" $
    it "allows customizing the function name" $ do
      binaryFold 'z' 'o' Zero `shouldBe` 'z'
      binaryFold 'z' 'o' One `shouldBe` 'o'

  describe "equivalence" $ do
    let checkBinaryFn f g a b x = f a b x `shouldBe` g a b x

    it "can be used to define bool" $ do
      let check = checkBinaryFn bool bool' "false" "true"
      check False
      check True

    it "can be used to define maybe" $ do
      let check = checkBinaryFn maybe maybe' "<empty>" (++ "!!!")
      check Nothing
      check (Just "Hello")

    it "can be used to define either" $ do
      let check = checkBinaryFn either either' show (++ "!!!")
      check (Left True)
      check (Right "Either")

    it "can be used to define foldr" $ do
      -- Well, we can get 'foldr', but flipped.
      let check = checkBinaryFn (flip foldr) foldr' (0 :: Int) (\_ acc -> acc + 1)
      check []
      check "Frobnicate"