{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Data.HFunctor.Interpret (
Interpret(..), forI
, getI
, collectI
, AndC
) where
import Control.Applicative
import Control.Applicative.Backwards
import Control.Applicative.Lift
import Control.Applicative.ListF
import Control.Applicative.Step
import Control.Comonad.Trans.Env (EnvT(..))
import Control.Monad.Freer.Church
import Control.Monad.Reader
import Control.Monad.Trans.Compose
import Control.Monad.Trans.Identity
import Control.Natural
import Data.Coerce
import Data.Constraint.Trivial
import Data.Functor.Bind
import Data.Functor.Coyoneda
import Data.Functor.Plus
import Data.Functor.Product
import Data.Functor.Reverse
import Data.Functor.Sum
import Data.Functor.These
import Data.HFunctor
import Data.Kind
import Data.Maybe
import Data.Pointed
import Data.Proxy
import Data.Semigroup.Foldable
import GHC.Generics hiding (C)
import qualified Control.Alternative.Free as Alt
import qualified Control.Applicative.Free as Ap
import qualified Control.Applicative.Free.Fast as FAF
import qualified Control.Applicative.Free.Final as FA
import qualified Data.Map.NonEmpty as NEM
class Inject t => Interpret t where
type C t :: (Type -> Type) -> Constraint
retract :: C t f => t f ~> f
retract = interpret id
interpret :: C t g => (f ~> g) -> t f ~> g
interpret f = retract . hmap f
{-# MINIMAL retract | interpret #-}
forI
:: (Interpret t, C t g)
=> t f a
-> (f ~> g)
-> g a
forI x f = interpret f x
getI
:: (Interpret t, C t (Const b))
=> (forall x. f x -> b)
-> t f a
-> b
getI f = getConst . interpret (Const . f)
collectI
:: (Interpret t, C t (Const [b]))
=> (forall x. f x -> b)
-> t f a
-> [b]
collectI f = getI ((:[]) . f)
instance Interpret Coyoneda where
type C Coyoneda = Functor
retract = lowerCoyoneda
interpret f (Coyoneda g x) = g <$> f x
instance Interpret Ap.Ap where
type C Ap.Ap = Applicative
retract = \case
Ap.Pure x -> pure x
Ap.Ap x xs -> x <**> retract xs
interpret = Ap.runAp
instance Interpret ListF where
type C ListF = Plus
retract = foldr (<!>) zero . runListF
interpret f = foldr ((<!>) . f) zero . runListF
instance Interpret NonEmptyF where
type C NonEmptyF = Alt
retract = asum1 . runNonEmptyF
interpret f = asum1 . fmap f . runNonEmptyF
instance Interpret MaybeF where
type C MaybeF = Plus
retract = fromMaybe zero . runMaybeF
interpret f = maybe zero f . runMaybeF
instance Monoid k => Interpret (MapF k) where
type C (MapF k) = Plus
retract = foldr (<!>) zero . runMapF
interpret f = foldr ((<!>) . f) zero . runMapF
instance Monoid k => Interpret (NEMapF k) where
type C (NEMapF k) = Alt
retract = asum1 . runNEMapF
interpret f = asum1 . fmap f . runNEMapF
instance Interpret Step where
type C Step = Unconstrained
retract = stepVal
interpret f = f . stepVal
instance Interpret Steps where
type C Steps = Alt
retract = asum1 . getSteps
interpret f = asum1 . NEM.map f . getSteps
instance Interpret Flagged where
type C Flagged = Unconstrained
retract = flaggedVal
interpret f = f . flaggedVal
instance Interpret (These1 f) where
type C (These1 f) = Plus
retract = \case
This1 _ -> zero
That1 y -> y
These1 _ y -> y
interpret f = \case
This1 _ -> zero
That1 y -> f y
These1 _ y -> f y
instance Interpret Alt.Alt where
type C Alt.Alt = Alternative
interpret = Alt.runAlt
instance Plus f => Interpret ((:*:) f) where
type C ((:*:) f) = Unconstrained
retract (_ :*: y) = y
instance Plus f => Interpret (Product f) where
type C (Product f) = Unconstrained
retract (Pair _ y) = y
instance Interpret ((:+:) f) where
type C ((:+:) f) = Plus
retract = \case
L1 _ -> zero
R1 y -> y
instance Interpret (Sum f) where
type C (Sum f) = Plus
retract = \case
InL _ -> zero
InR y -> y
instance Interpret (M1 i c) where
type C (M1 i c) = Unconstrained
retract (M1 x) = x
interpret f (M1 x) = f x
instance Interpret Free where
type C Free = Monad
retract = retractFree
interpret = interpretFree
instance Interpret Free1 where
type C Free1 = Bind
retract = retractFree1
interpret = interpretFree1
instance Interpret FA.Ap where
type C FA.Ap = Applicative
retract = FA.retractAp
interpret = FA.runAp
instance Interpret FAF.Ap where
type C FAF.Ap = Applicative
retract = FAF.retractAp
interpret = FAF.runAp
instance Interpret IdentityT where
type C IdentityT = Unconstrained
retract = coerce
interpret f = f . runIdentityT
instance Interpret Lift where
type C Lift = Pointed
retract = elimLift point id
interpret = elimLift point
instance Interpret MaybeApply where
type C MaybeApply = Pointed
retract = either id point . runMaybeApply
interpret f = either f point . runMaybeApply
instance Interpret Backwards where
type C Backwards = Unconstrained
retract = forwards
interpret f = f . forwards
instance Interpret WrappedApplicative where
type C WrappedApplicative = Unconstrained
retract = unwrapApplicative
interpret f = f . unwrapApplicative
instance Interpret (ReaderT r) where
type C (ReaderT r) = MonadReader r
retract x = runReaderT x =<< ask
interpret f x = f . runReaderT x =<< ask
instance Monoid e => Interpret (EnvT e) where
type C (EnvT e) = Unconstrained
retract (EnvT _ x) = x
interpret f (EnvT _ x) = f x
instance Interpret Reverse where
type C Reverse = Unconstrained
retract = getReverse
interpret f = f . getReverse
instance Interpret ProxyF where
type C ProxyF = Impossible
retract = nope . reProxy
reProxy :: p f a -> Proxy f
reProxy _ = Proxy
instance Monoid e => Interpret (ConstF e) where
type C (ConstF e) = Impossible
retract = nope . reProxy
class (c a, d a) => AndC c d a
instance (c a, d a) => AndC c d a
instance (Interpret s, Interpret t) => Interpret (ComposeT s t) where
type C (ComposeT s t) = AndC (C s) (C t)
retract = interpret retract . getComposeT
interpret f = interpret (interpret f) . getComposeT
instance Interpret t => Interpret (HLift t) where
type C (HLift t) = C t
retract = \case
HPure x -> x
HOther x -> retract x
interpret f = \case
HPure x -> f x
HOther x -> interpret f x
instance Interpret t => Interpret (HFree t) where
type C (HFree t) = C t
retract = \case
HReturn x -> x
HJoin x -> interpret retract x