Arrow-based matchers

ArrowMatcher.hs

-- Arrowized version of https://github.com/tcrayford/rematch

{-# LANGUAGE RankNTypes, Arrows, FlexibleInstances, MultiParamTypeClasses #-}
module ArrowMatcher where

import Prelude hiding ((.), id)
import Control.Applicative
import Control.Category
import Control.Arrow
import Control.Arrow.Transformer
import Control.Arrow.Transformer.Error
import Control.Rematch (standardMismatch)
import Control.Rematch.Formatting
import Control.Rematch.Run
import Data.Either
import Data.Monoid
import Text.Printf

-- Some standard definitions
data ProductA a b x y =
  ProductA (a x y) (b x y)
instance (Category a, Category b) => Category (ProductA a b) where
  id = ProductA id id
  ProductA a1 b1 . ProductA a2 b2 =
    ProductA (a1 . a2) (b1 . b2)
instance (Arrow a, Arrow b) => Arrow (ProductA a b) where
  arr f = ProductA (arr f) (arr f)
  first (ProductA a b) = ProductA (first a) (first b)
instance (ArrowChoice a, ArrowChoice b) => ArrowChoice (ProductA a b) where
  left (ProductA a b) = ProductA (left a) (left b)
instance (ArrowApply a, ArrowApply b) => ArrowApply (ProductA a b) where
  app =
    ProductA
      (proc (ProductA fa fb, x) -> fa -<< x)
      (proc (ProductA fa fb, x) -> fb -<< x)
  
newtype ConstA w b c = ConstA w
instance Monoid w => Category (ConstA w) where
  id = ConstA mempty
  ConstA w1 . ConstA w2 = ConstA (w1 <> w2)
instance Monoid w => Arrow (ConstA w) where
  arr _ = ConstA mempty
  first (ConstA w) = ConstA w
instance Monoid w => ArrowChoice (ConstA w) where
  left (ConstA w) = ConstA w
instance Monoid w => ArrowApply (ConstA w) where
  app = ConstA mempty

newtype ContA r a b c = ContA (a c r -> a b r)
instance Category (ContA r a) where
  id = ContA id
  ContA a . ContA b = ContA (b . a)
instance ArrowApply a => Arrow (ContA r a) where
  arr f = ContA (. arr f)
  first (ContA z) = ContA $ \x ->
    proc (b,d) ->
      z $ x . arr (\b -> (b,d)) -<< b
instance ArrowApply a => ArrowTransformer (ContA r) a where
  lift a = ContA (. a)

-- Definition of Matcher
type PropertyDesc = String
type DataDesc = String
type Matcher =
  ContA ()
    (ProductA
      (ConstA PropertyDesc)
      (ErrorArrow DataDesc (->)))

runMatch :: Matcher a b -> a -> Match
runMatch (ContA z) a =
  case z (arr (const ())) of 
    ProductA (ConstA prop) (ErrorArrow f)
      | Left was <- f a ->
          MatchFailure $
            "\nExpected: " ++ prop ++
            "\n     but: " ++ was
      | otherwise -> MatchSuccess

matcher
  :: (PropertyDesc -> PropertyDesc)
  -> ((b -> Either DataDesc ()) -> (a -> Either DataDesc ()))
  -> Matcher a b
matcher p z = ContA $
  \(ProductA (ConstA desc)     (ErrorArrow f)) -> 
    ProductA (ConstA $ p desc) (ErrorArrow $ z f)

simpleMatcher
  :: PropertyDesc
  -> (a -> Either DataDesc ())
  -> Matcher a a
simpleMatcher desc test =
  lift $ ProductA (ConstA desc) $ ErrorArrow $ proc a ->
    returnA -< a <$ test a

is :: (Eq a, Show a) => a -> Matcher a a
is expected =
  simpleMatcher ("equalTo " ++ show expected) $ \real ->
    if real == expected
      then Right ()
      else Left $ standardMismatch real

everyItem :: Matcher [a] a
everyItem =
  matcher
    (printf "everyItem(%s)") $ \k list ->
      let errs = lefts $ map k list in
      if null errs
        then Right ()
        else Left $ describeList "" errs

hasJust :: Matcher (Maybe a) a
hasJust =
  matcher
    (printf "hasJust(%s)") $ \k mb ->
      case mb of
        Nothing -> Left "but was Nothing"
        Just x -> k x

Structures that are covariant in one component and contravariant in the other are called profunctors. You can find a few introductions to them on the internet, like https://www.fpcomplete.com/school/pick-of-the-week/profunctors

Arrows are a special case of profunctors, with more structure.

I intentionally split the main arrow into components, in the hope it'd make it easier to understand.

So there are 3 things going on here:

1. ErrorArrow provides the ability for a matcher to fail with a message. This should be more or less straightforward.
2. ErrorArrow is paired with the constant arrow, ConstA. The constant arrow records the name of the property. It is important that we can get hold of that name without providing any real input.
3. Finally, we wrap the whole thing into the continuation arrow, ContA. It is needed both to form the name and to perform the actual testing.

To explain the last point, consider the arrow everyItem that has type Matcher [a] a. If Matcher was an ordinary arrow, like ->, it had to choose a particular element from the list and return it. That would be wrong, of course. But thanks to the continuation arrow, we can grab the whole continuation, apply it to every element of the list, and then combine the results.

In some sense, continuation passing was explicit in Tom's original code, since everyItem took another matcher as an argument. My approach hides continuation passing in the arrow combinators.

Thanks for the pointers!