{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
module Data.Matchable.TH.Matcher(
    Matcher(..),
    addInfo, 
    matcherToFun,
    
    matcherExpr, 
    funMatcher, liftMatcher, liftMatcher2, combineMatchers
) where

import           Language.Haskell.TH

data Matcher u = Matcher
  { forall u. Matcher u -> PatQ
leftPat        :: PatQ
  , forall u. Matcher u -> PatQ
rightPat       :: PatQ
  , forall u. Matcher u -> ExpQ
bodyExp        :: ExpQ
  , forall u. Matcher u -> u
additionalInfo :: u }
  deriving forall a b. a -> Matcher b -> Matcher a
forall a b. (a -> b) -> Matcher a -> Matcher b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Matcher b -> Matcher a
$c<$ :: forall a b. a -> Matcher b -> Matcher a
fmap :: forall a b. (a -> b) -> Matcher a -> Matcher b
$cfmap :: forall a b. (a -> b) -> Matcher a -> Matcher b
Functor

addInfo :: Semigroup a => a -> Matcher a -> Matcher a
addInfo :: forall a. Semigroup a => a -> Matcher a -> Matcher a
addInfo a
a = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
a forall a. Semigroup a => a -> a -> a
<>)

matcherToFun :: Matcher a -> ExpQ
matcherToFun :: forall u. Matcher u -> ExpQ
matcherToFun Matcher a
matcher = forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall u. Matcher u -> PatQ
leftPat Matcher a
matcher, forall u. Matcher u -> PatQ
rightPat Matcher a
matcher] (forall u. Matcher u -> ExpQ
bodyExp Matcher a
matcher)

matcherExpr :: (ExpQ -> ExpQ -> ExpQ) -> a -> Q (Matcher a)
matcherExpr :: forall a. (ExpQ -> ExpQ -> ExpQ) -> a -> Q (Matcher a)
matcherExpr ExpQ -> ExpQ -> ExpQ
expr a
a = do
  Name
l <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"l"
  Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Matcher
    { leftPat :: PatQ
leftPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
l
    , rightPat :: PatQ
rightPat = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r
    , bodyExp :: ExpQ
bodyExp = ExpQ -> ExpQ -> ExpQ
expr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
l) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r)
    , additionalInfo :: a
additionalInfo = a
a }

funMatcher :: ExpQ -> a -> Q (Matcher a)
funMatcher :: forall a. ExpQ -> a -> Q (Matcher a)
funMatcher ExpQ
f = forall a. (ExpQ -> ExpQ -> ExpQ) -> a -> Q (Matcher a)
matcherExpr (\ExpQ
l ExpQ
r -> [| $f $l $r |])

liftMatcher :: ExpQ -> Matcher a -> Q (Matcher a)
liftMatcher :: forall a. ExpQ -> Matcher a -> Q (Matcher a)
liftMatcher ExpQ
lifter Matcher a
matcher = forall a. ExpQ -> a -> Q (Matcher a)
funMatcher [| $lifter $fun |] (forall u. Matcher u -> u
additionalInfo Matcher a
matcher)
  where
    fun :: ExpQ
fun = forall u. Matcher u -> ExpQ
matcherToFun Matcher a
matcher

liftMatcher2 :: (Semigroup a) => ExpQ -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 :: forall a.
Semigroup a =>
ExpQ -> Matcher a -> Matcher a -> Q (Matcher a)
liftMatcher2 ExpQ
lifter Matcher a
matcher1 Matcher a
matcher2 = forall a. ExpQ -> a -> Q (Matcher a)
funMatcher [| $lifter $fun1 $fun2 |] a
info'
  where
    fun1 :: ExpQ
fun1 = forall u. Matcher u -> ExpQ
matcherToFun Matcher a
matcher1
    fun2 :: ExpQ
fun2 = forall u. Matcher u -> ExpQ
matcherToFun Matcher a
matcher2
    info' :: a
info' = forall u. Matcher u -> u
additionalInfo Matcher a
matcher1 forall a. Semigroup a => a -> a -> a
<> forall u. Matcher u -> u
additionalInfo Matcher a
matcher2

combineMatchers :: (Monoid a) => ([PatQ] -> PatQ) -> ([ExpQ] -> ExpQ) -> [Matcher a] -> Matcher a
combineMatchers :: forall a.
Monoid a =>
([PatQ] -> PatQ) -> ([ExpQ] -> ExpQ) -> [Matcher a] -> Matcher a
combineMatchers [PatQ] -> PatQ
patCombiner [ExpQ] -> ExpQ
expCombiner [Matcher a]
matchers =
  Matcher {
    leftPat :: PatQ
leftPat = [PatQ] -> PatQ
patCombiner (forall u. Matcher u -> PatQ
leftPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher a]
matchers)
  , rightPat :: PatQ
rightPat = [PatQ] -> PatQ
patCombiner (forall u. Matcher u -> PatQ
rightPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher a]
matchers)
  , bodyExp :: ExpQ
bodyExp = [ExpQ] -> ExpQ
expCombiner (forall u. Matcher u -> ExpQ
bodyExp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Matcher a]
matchers)
  , additionalInfo :: a
additionalInfo = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall u. Matcher u -> u
additionalInfo [Matcher a]
matchers
  }