{-# 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 }