Junction.hs

{-# LANGUAGE FlexibleInstances, DeriveGeneric #-}

-- http://design.perl6.org/S09.html#Junctions
module Junction where

import GHC.Generics
import Test.QuickCheck
import Control.Applicative

data Junction a = Pure a
                | Any [Junction a]
                | All [Junction a]
                | One [Junction a]
                | Not (Junction a)
                  deriving (Show, Generic)

-- I'd like to do something a little more general, but I'm not sure exactly how.
-- Could probably exhaustively generate truth-tables?
instance Eq (Junction Bool) where a == b = test a == test b

none :: [Junction a] -> Junction a
none = All . map Not
-- or, semi-equivalently (but see `pair', below):
-- none = Not . Any

-- The raison d'etre of junctions.
test :: Junction Bool -> Bool
test (Pure x) = x
test (Any l) = any test l
test (All l) = all test l
test (One l) = 1 == length (filter test l)
test (Not a) = not (test a)

instance Functor Junction where
    fmap f (Pure x)  = Pure (f x)
    fmap f (Any l)   = Any (map (fmap f) l)
    fmap f (All l)   = All (map (fmap f) l)
    fmap f (One l)   = One (map (fmap f) l)
    fmap f (Not a)   = Not (fmap f a)

-- See http://design.perl6.org/S09.html#Junctions
--
-- The sentences near "If two or more arguments are junctive" are particularly
-- relevant here.
pair :: Junction a -> Junction b -> Junction (a,b)
-- left-most all or none junction first
pair (Not a)  b        = Not (pair a b)
pair (All as) b        = All [pair a b | a <- as]
pair a        (Not b)  = Not (pair a b)
pair a        (All bs) = All [pair a b | b <- bs]
-- otherwise, the leftmost any or one junction
pair (Any as) b        = Any [pair a b | a <- as]
pair (One as) b        = One [pair a b | a <- as]
pair a        (Any bs) = Any [pair a b | b <- bs]
pair a        (One bs) = One [pair a b | b <- bs]
-- and finally, the nop case.
pair (Pure a) (Pure b) = Pure (a,b)

instance Applicative Junction where
    pure = Pure
    f <*> x = uncurry ($) <$> pair f x


-- QuickCheck infrastructure
instance Arbitrary a => Arbitrary (Junction a) where
    shrink = genericShrink
    arbitrary = sized arb
        where arb 0 = Pure <$> arbitrary
              arb n = oneof [ Pure <$> arbitrary
                            , Any <$> listOf (arb (n-1))
                            , All <$> listOf (arb (n-1))
                            , One <$> listOf (arb (n-1))
                            , Not <$> arb (n-1) ]

-- Some QuickCheck tests for the applicative laws.
swap (a,b) = (b,a)
test_swap :: (a -> a -> Bool) -> Junction a -> Junction a -> Bool
test_swap f a b = (uncurry f . swap <$> pair a b) == (uncurry f <$> pair b a)

prop_a :: Junction Int -> Junction Int -> Bool
prop_a = test_swap (<)