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

Thanks for the pointers!