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

Looks both painful and attractive. Now I am afraid I might spend the night trying to understand this.

The problem with using more abstraction is that you require more effort from the user who wants to really understand what is going on. Original question on the list was about how to make combinators for Matcher which is contravariant in a. A simpleton like me expected something at this level:

data Matcher m a =
    Monoid m =>
    Matcher (a -> m)

I assume your arrowized solution has something like this as a special case. Are there some motivating examples which work in the Arrow Matcher but not in the dumb matcher like above?

Can you suggest something to read on structures like above? I heard "contravariant functors" mentioned once, is there a type class?

I have actually been working on some compositional serializer library for F#, a Haskell model might look like this:

https://gist.github.com/toyvo/0caecefc674a46ea4a93

In that setting the X a type is two independent components - one covariant in a and one contravariant in a. So it was natural to use Applicative + Functor for the "reader" part, but I struggled a bit with the "Writer". "a -> m" with an arbitrary monoid "m" is the closest structure I came up with that I felt comfortable using.

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!