content: {-# LANGUAGE ApplicativeDo #-}
  {-# LANGUAGE MagicHash #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE StrictData #-}
  {-# LANGUAGE TemplateHaskellQuotes #-}
  {-# LANGUAGE TupleSections #-}
  
  -- | Defines various mappings between categorical representations and the plugin, allowing us to
  --   support transformations against different type class hierarchies.
  module Categorifier.Hierarchy
    ( First (..),
      Last,
      pattern Last,
      getLast,
      HaskOps (..),
      Hierarchy (..),
  
      -- * concrete hierarchies
      baseHierarchy,
      emptyHierarchy,
      concatOps,
  
      -- * building hierarchies
      findDataCon,
      findId,
      findTHName,
      findTyCon,
      identifier,
      nameFromText,
      mkFunctionApps,
      mkMethodApps,
      mkMethodApps',
  
      -- * lookup of identifier info from @base@
  
      --
      -- Many things are not built into the compiler, but sometimes (especially in connection with
      -- @baseMakers@ / `Categorifier.Core.PrimOp.replace`), we need to recognize these things.  The
      -- `Lookup` monad run outside the call to `Categorifier.Core.Categorify.categorify` is where we
      -- can query the compiler for this information.
      BaseIdentifiers (..),
      getBaseIdentifiers,
  
      -- ** Fixed-size integer constructors
      IntConstructor (..),
      getIntegerConstructors,
      intConstructorToOpTyPair,
      intConstructorToBoxer,
  
      -- ** `GHC.Base.getTag`
      GetTagInfo (..),
      getGetTagInfo,
    )
  where
  
  import qualified Categorifier.Category
  import qualified Categorifier.Client
  import qualified Categorifier.Core.Base
  import qualified Categorifier.Core.Functions
  import Categorifier.Core.Types (CategoryStack, Lookup, MissingSymbol (..))
  import Categorifier.Duoidal (Parallel (..))
  import qualified Categorifier.GHC.Builtin as Plugins
  import Categorifier.GHC.Core (CoreExpr, CoreM, Type)
  import qualified Categorifier.GHC.Core as Plugins
  import qualified Categorifier.GHC.Data as Plugins
  import qualified Categorifier.GHC.Plugins as Plugins (thNameToGhcName)
  import qualified Categorifier.GHC.Runtime as Plugins
  import qualified Categorifier.GHC.Types as Plugins
  import qualified Categorifier.GHC.Unit as Plugins
  import Control.Applicative (Alternative (..))
  import qualified Control.Applicative
  import qualified Control.Arrow
  import qualified Control.Category
  import Control.Monad ((<=<))
  import qualified Control.Monad
  import Control.Monad.Trans.Except (ExceptT (..))
  import Data.Bifunctor (bimap)
  import Data.Bits (FiniteBits (..))
  import qualified Data.Bool
  import qualified Data.Either
  import qualified Data.Foldable
  import qualified Data.Function
  import Data.Functor.Identity (Identity (..))
  import Data.Maybe (fromMaybe)
  import Data.Monoid (Dual (..))
  import Data.Text (Text)
  import qualified Data.Text as Text
  import qualified Data.Tuple
  import qualified GHC.Base
  import qualified GHC.Classes
  import qualified GHC.Err
  import qualified GHC.Float
  import qualified GHC.Int
  import qualified GHC.Real
  import qualified GHC.Word
  import qualified Language.Haskell.TH as TH
  import qualified Numeric
  import qualified Unsafe.Coerce
  import Prelude hiding (mod)
  
  -- | These are operations that we need to use in __Hask__, rather than in the target category.
  data HaskOps f = HaskOps
    { -- | @forall a. Rep a -> a@
      abstH :: (CoreExpr -> f CoreExpr) -> Type -> f CoreExpr,
      -- | @forall a b c. (a -> c) -> (b -> c) -> Either a b -> c@
      eitherH :: Type -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr,
      -- | @forall cat i a b. i -> (a -> b) -> cat a b@
      ffcallH ::
        (CoreExpr -> f CoreExpr) ->
        Type ->
        Type ->
        Type ->
        Type ->
        CoreExpr ->
        CoreExpr ->
        f CoreExpr,
      -- | @forall a. (a -> a) -> a@
      fixH :: Type -> CoreExpr -> CoreExpr,
      -- | @forall a b. (a, b) -> a@
      fstH :: Type -> Type -> CoreExpr -> CoreExpr,
      -- | @forall cat a b. String -> cat a b -> cat a b@
      indirectionH ::
        (CoreExpr -> f CoreExpr) ->
        Type ->
        Type ->
        Type ->
        CoreExpr ->
        f CoreExpr,
      -- | @forall a. a -> Rep a@
      reprH :: (CoreExpr -> f CoreExpr) -> Type -> f CoreExpr,
      -- | @forall a b. (a, b) -> b@
      sndH :: Type -> Type -> CoreExpr -> CoreExpr,
      -- | @forall a b c. ((a, b) -> c) -> a -> b -> c@
      curryH :: Type -> Type -> Type -> CoreExpr -> CoreExpr
    }
  
  concatOps :: (Monad f) => Lookup (HaskOps f)
  concatOps = do
    abstH <- repOp 'Categorifier.Core.Functions.abst
    eitherH <- do
      op <- identifier 'Data.Either.either
      pure (\a b c f g e -> runIdentity $ mkFunctionApps Identity op [a, c, b] [f, g, e])
    ffcallH <- do
      op <- identifier 'Categorifier.Category.ffcall
      pure $ \onDict cat ity a b i f ->
        mkMethodApps onDict op [cat, ity, a, b] [] [i, f]
    fixH <- do
      op <- identifier 'Data.Function.fix
      pure (\t e -> runIdentity $ mkFunctionApps Identity op [t] [e])
    fstH <- do
      op <- identifier 'Data.Tuple.fst
      pure (\a b e -> runIdentity $ mkFunctionApps Identity op [a, b] [e])
    indirectionH <- do
      op <- identifier 'Categorifier.Category.indirection
      pure $ \onDict cat a b s ->
        mkMethodApps onDict op [Plugins.typeKind a, Plugins.typeKind b, cat, a, b] [] [s]
    reprH <- repOp 'Categorifier.Core.Functions.repr
    sndH <- do
      op <- identifier 'Data.Tuple.snd
      pure (\a b e -> runIdentity $ mkFunctionApps Identity op [a, b] [e])
    curryH <- do
      op <- identifier 'Data.Tuple.curry
      pure (\a b c e -> runIdentity $ mkFunctionApps Identity op [a, b, c] [e])
    pure HaskOps {..}
    where
      repOp name = do
        op <- identifier name
        pure $ \onDict a -> mkFunctionApps onDict op [a] []
  
  -- | This structure relates categorical concepts to operations in a particular library. Each field
  --   can be either `Nothing` (if there is no way to model that operation in the library) or some
  --   function that expects the correct set of type parameters. The resulting expression should match
  --   the type of the operation in the comment for that field (with the type arguments fully
  --   applied).
  --
  --  __TODO__: We should perhaps have the fields return @`Categorifier.Core.Makers.CategoryStack`
  --           `CoreExpr`@ so implementations can fail to handle some cases.
  data Hierarchy f = Hierarchy
    { -- | @forall cat a. cat a a@
      absV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Rep a) a@
      abstCV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      acosV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      acoshV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat. cat (Prod Bool Bool) Bool@
      andV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> f CoreExpr),
      -- | @forall cat f a b. cat (Prod (f (Exp a b)) (f a)) (f b)@
      apV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. Semigroup a. cat (Prod a a) a@
      appendV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat (Prod (Exp a b) a) b@
      applyV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat x a b -> cat x (a -> b) -> cat x a -> cat x b@
      apply2V ::
        Maybe
          ( (CoreExpr -> f CoreExpr) ->
            Type ->
            Type ->
            Type ->
            Type ->
            CoreExpr ->
            CoreExpr ->
            f CoreExpr
          ),
      -- | @forall cat a. cat (Prod a a) a@
      arctan2V :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      asinV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      asinhV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      atanV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      atanhV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat m a b. cat (Prod (m a) (Exp a (m b)) (m b)@
      bindV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat a b@
      bottomV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat from to. cat from to@
      coerceV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) Ordering@
      compareV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b c. cat b c -> cat a b -> cat a c@
      composeV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat x b c a. cat x (b -> c) -> cat x (a -> b) -> cat x (a -> c)@
      compose2V ::
        Maybe
          ( (CoreExpr -> f CoreExpr) ->
            Type ->
            Type ->
            Type ->
            Type ->
            Type ->
            CoreExpr ->
            CoreExpr ->
            f CoreExpr
          ),
      -- | @forall cat a b. b -> cat a b@
      constV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. b -> cat a b@
      constraintV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      cosV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      coshV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a1 a2 b. cat (Prod a1 a2) b -> cat a1 (Exp a2 b)@
      curryV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b c. cat (Prod a (Coprod b c)) (Coprod (Prod a b) (Prod a c)) @
      distlV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) a@
      divV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) a@
      divideV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat. cat Double Float@
      doubleToFloatV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) Bool@
      equalV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a Bool@
      evenV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat (Prod a b) a@
      exlV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      expV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat (Prod a b) b@
      exrV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a x. cat (Prod a x) x -> cat a x@
      fixV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat. cat Float Double@
      floatToDoubleV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) a@
      fmodV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b1 b2. cat a b1 -> cat a b2 -> cat a (Prod b1 b2)@
      forkV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a Bool@
      fpIsNegativeZeroV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a Bool@
      fpIsInfiniteV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a Bool@
      fpIsFiniteV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a Bool@
      fpIsNaNV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a Bool@
      fpIsDenormalV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat Integer a@
      --
      --  __TODO__: This is simply a specialization of `fromIntegralV`, but it's difficult to look up
      --            type constructors outside of this context, so we make it part of the hierarchy,
      --            but we shouldn't have to.
      fromIntegerV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat a b@
      fromIntegralV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) Bool@
      geV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) Bool@
      gtV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      idV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod Bool (Prod a a)) a@
      ifV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat a (Coprod a b)@
      inlV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat b (Coprod a b)@
      inrV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a1 a2 b. cat a1 b -> cat a2 b -> cat (Coprod a1 a2) c@
      joinV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b c. cat (Prod a (Prod b c)) (Prod (Prod a b) c)@
      lassocV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) Bool@
      leV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a b c. cat (Prod a b) c -> cat (Prod (f a) (f b)) (f c)@
      liftA2V ::
        Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      logV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) Bool@
      ltV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat cat' f a b. cat a b -> cat' (f a) (f b)@
      --
      --  __NB__: This is not necessarily an endofunctor. It expects /two/ categories, which may
      --          differ.
      mapV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. Ord a. cat (Prod a a) a@
      maxV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a. cat (f a) a@
      maximumV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. Ord a. cat (Prod a a) a@
      minV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a. cat (f a) a@
      minimumV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. Semiring a. cat (Prod a a) a@
      minusV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) a@
      modV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat tag a b. cat a b@
      nativeV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. Semiring a. cat a a@
      negateV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a. cat (f a) (Exp (Rep f) a)@
      indexV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a. cat (Exp (Rep f) a) (f a)@
      tabulateV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat. cat Bool Bool@
      notV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) Bool@
      notEqualV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a Bool@
      oddV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat. cat (Prod Bool Bool) Bool@
      orV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> f CoreExpr),
      -- | @forall cat a. Semiring a. cat (Prod a a) a@
      plusV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a. cat a (f a)
      pointV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) a@
      powV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a i. i -> cat a a@
      powIV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> CoreExpr -> f CoreExpr),
      -- | @forall cat a. cat (a, Int) a@
      powIntV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) a@
      quotV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b c. cat (Prod (Prod a b) c) (Prod a (Prod b c))@
      rassocV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat a b@
      realToFracV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      recipV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat (Prod a a) a@
      remV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a (Rep a) @
      reprCV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat t f a. cat (t (f a)) (f (t a))
      sequenceAV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      signumV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      sinV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      sinhV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      sqrtV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a b. cat (Prod a (f b)) (f (Prod a b))@
      strengthV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat f a. cat (f a) a@
      sumV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a b. cat (Prod a b) (Prod b a)@
      swapV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      tanV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. cat a a@
      tanhV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat a. Semiring a. cat (Prod a a) a@
      timesV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> f CoreExpr),
      -- | @forall cat t f a b. cat a (f b) -> cat (t a) (f (t b))@
      traverseV ::
        Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> Type -> f CoreExpr),
      -- | @forall cat a1 a2 b. cat a1 (Exp a2 b) -> cat (Prod a1 a2) b@
      uncurryV :: Maybe ((CoreExpr -> f CoreExpr) -> Type -> Type -> Type -> Type -> f CoreExpr)
    }
  
  -- | Like `Data.Monoid.First`, but more general, as it isn't restricted to `Maybe`.
  newtype First a = First {getFirst :: a}
  
  -- | This default instance /always/ chooses the first argument. If your @a@ is a monoid (see
  --   @`First` (`Maybe` a)@), or is somehow mergable (see @`First` (`Hierarchy` f)@), then it's
  --   better to create an @overlapping@ instance.
  instance {-# OVERLAPPABLE #-} Semigroup (First a) where
    (<>) = const
  
  instance Semigroup (First (Maybe a)) where
    First a <> First b = First $ a <|> b
  
  type Last a = Dual (First a)
  
  pattern Last :: a -> Last a
  pattern Last a = Dual (First a)
  
  getLast :: Last a -> a
  getLast = getFirst . getDual
  
  instance Semigroup (First (Hierarchy f)) where
    First a <> First b =
      First $
        Hierarchy
          { absV = absV a <|> absV b,
            abstCV = abstCV a <|> abstCV b,
            acosV = acosV a <|> acosV b,
            acoshV = acoshV a <|> acoshV b,
            andV = andV a <|> andV b,
            apV = apV a <|> apV b,
            appendV = appendV a <|> appendV b,
            applyV = applyV a <|> applyV b,
            apply2V = apply2V a <|> apply2V b,
            arctan2V = arctan2V a <|> arctan2V b,
            asinV = asinV a <|> asinV b,
            asinhV = asinhV a <|> asinhV b,
            atanV = atanV a <|> atanV b,
            atanhV = atanhV a <|> atanhV b,
            bindV = bindV a <|> bindV b,
            bottomV = bottomV a <|> bottomV b,
            coerceV = coerceV a <|> coerceV b,
            compareV = compareV a <|> compareV b,
            composeV = composeV a <|> composeV b,
            compose2V = compose2V a <|> compose2V b,
            constV = constV a <|> constV b,
            constraintV = constraintV a <|> constraintV b,
            cosV = cosV a <|> cosV b,
            coshV = coshV a <|> coshV b,
            curryV = curryV a <|> curryV b,
            distlV = distlV a <|> distlV b,
            divV = divV a <|> divV b,
            divideV = divideV a <|> divideV b,
            doubleToFloatV = doubleToFloatV a <|> doubleToFloatV b,
            equalV = equalV a <|> equalV b,
            evenV = evenV a <|> evenV b,
            exlV = exlV a <|> exlV b,
            expV = expV a <|> expV b,
            exrV = exrV a <|> exrV b,
            fixV = fixV a <|> fixV b,
            floatToDoubleV = floatToDoubleV a <|> floatToDoubleV b,
            fmodV = fmodV a <|> fmodV b,
            forkV = forkV a <|> forkV b,
            fpIsNegativeZeroV = fpIsNegativeZeroV a <|> fpIsNegativeZeroV b,
            fpIsInfiniteV = fpIsInfiniteV a <|> fpIsInfiniteV b,
            fpIsFiniteV = fpIsFiniteV a <|> fpIsFiniteV b,
            fpIsNaNV = fpIsNaNV a <|> fpIsNaNV b,
            fpIsDenormalV = fpIsDenormalV a <|> fpIsDenormalV b,
            fromIntegerV = fromIntegerV a <|> fromIntegerV b,
            fromIntegralV = fromIntegralV a <|> fromIntegralV b,
            geV = geV a <|> geV b,
            gtV = gtV a <|> gtV b,
            idV = idV a <|> idV b,
            ifV = ifV a <|> ifV b,
            inlV = inlV a <|> inlV b,
            inrV = inrV a <|> inrV b,
            joinV = joinV a <|> joinV b,
            lassocV = lassocV a <|> lassocV b,
            leV = leV a <|> leV b,
            liftA2V = liftA2V a <|> liftA2V b,
            logV = logV a <|> logV b,
            ltV = ltV a <|> ltV b,
            mapV = mapV a <|> mapV b,
            maxV = maxV a <|> maxV b,
            maximumV = maximumV a <|> maximumV b,
            minV = minV a <|> minV b,
            minimumV = minimumV a <|> minimumV b,
            minusV = minusV a <|> minusV b,
            modV = modV a <|> modV b,
            nativeV = nativeV a <|> nativeV b,
            negateV = negateV a <|> negateV b,
            indexV = indexV a <|> indexV b,
            tabulateV = tabulateV a <|> tabulateV b,
            notV = notV a <|> notV b,
            notEqualV = notEqualV a <|> notEqualV b,
            oddV = oddV a <|> oddV b,
            orV = orV a <|> orV b,
            plusV = plusV a <|> plusV b,
            pointV = pointV a <|> pointV b,
            powV = powV a <|> powV b,
            powIV = powIV a <|> powIV b,
            powIntV = powIntV a <|> powIntV b,
            quotV = quotV a <|> quotV b,
            rassocV = rassocV a <|> rassocV b,
            realToFracV = realToFracV a <|> realToFracV b,
            recipV = recipV a <|> recipV b,
            remV = remV a <|> remV b,
            reprCV = reprCV a <|> reprCV b,
            sequenceAV = sequenceAV a <|> sequenceAV b,
            signumV = signumV a <|> signumV b,
            sinV = sinV a <|> sinV b,
            sinhV = sinhV a <|> sinhV b,
            sqrtV = sqrtV a <|> sqrtV b,
            strengthV = strengthV a <|> strengthV b,
            sumV = sumV a <|> sumV b,
            swapV = swapV a <|> swapV b,
            tanV = tanV a <|> tanV b,
            tanhV = tanhV a <|> tanhV b,
            timesV = timesV a <|> timesV b,
            traverseV = traverseV a <|> traverseV b,
            uncurryV = uncurryV a <|> uncurryV b
          }
  
  instance Monoid (First (Hierarchy f)) where
    mempty = First emptyHierarchy
  
  -- | If you are building a custom hierarchy, it is worth considering whether you want to populate
  --   the record from `Hierarchy` or from `emptyHierarchy`. Most of the ones provided in this library
  --   are built from `Hierarchy`, because it is easier to keep in sync with changes that way and we
  --   can update them in lock-step. If you are defining a hierarchy within a specific application,
  --   you probably want to do the same to ensure that changes in this library are caught. However, if
  --   you are publishing a hierarchy in a separate library, building from `emptyHierarchy` is more
  --   future-proof. As we add more operations, your library will continue to work, it just won't
  --   support the new operations.
  emptyHierarchy :: Hierarchy f
  emptyHierarchy =
    Hierarchy
      { absV = Nothing,
        abstCV = Nothing,
        acosV = Nothing,
        acoshV = Nothing,
        andV = Nothing,
        apV = Nothing,
        appendV = Nothing,
        applyV = Nothing,
        apply2V = Nothing,
        arctan2V = Nothing,
        asinV = Nothing,
        asinhV = Nothing,
        atanV = Nothing,
        atanhV = Nothing,
        bindV = Nothing,
        bottomV = Nothing,
        coerceV = Nothing,
        compareV = Nothing,
        composeV = Nothing,
        compose2V = Nothing,
        constV = Nothing,
        constraintV = Nothing,
        cosV = Nothing,
        coshV = Nothing,
        curryV = Nothing,
        distlV = Nothing,
        divV = Nothing,
        divideV = Nothing,
        doubleToFloatV = Nothing,
        equalV = Nothing,
        evenV = Nothing,
        exlV = Nothing,
        expV = Nothing,
        exrV = Nothing,
        fixV = Nothing,
        floatToDoubleV = Nothing,
        fmodV = Nothing,
        forkV = Nothing,
        fpIsNegativeZeroV = Nothing,
        fpIsInfiniteV = Nothing,
        fpIsFiniteV = Nothing,
        fpIsNaNV = Nothing,
        fpIsDenormalV = Nothing,
        fromIntegerV = Nothing,
        fromIntegralV = Nothing,
        geV = Nothing,
        gtV = Nothing,
        idV = Nothing,
        ifV = Nothing,
        inlV = Nothing,
        inrV = Nothing,
        joinV = Nothing,
        lassocV = Nothing,
        leV = Nothing,
        liftA2V = Nothing,
        logV = Nothing,
        ltV = Nothing,
        mapV = Nothing,
        maxV = Nothing,
        maximumV = Nothing,
        minV = Nothing,
        minimumV = Nothing,
        minusV = Nothing,
        modV = Nothing,
        negateV = Nothing,
        indexV = Nothing,
        tabulateV = Nothing,
        nativeV = Nothing,
        notV = Nothing,
        notEqualV = Nothing,
        oddV = Nothing,
        orV = Nothing,
        plusV = Nothing,
        pointV = Nothing,
        powV = Nothing,
        powIV = Nothing,
        powIntV = Nothing,
        quotV = Nothing,
        rassocV = Nothing,
        realToFracV = Nothing,
        recipV = Nothing,
        remV = Nothing,
        reprCV = Nothing,
        sequenceAV = Nothing,
        signumV = Nothing,
        sinV = Nothing,
        sinhV = Nothing,
        sqrtV = Nothing,
        strengthV = Nothing,
        sumV = Nothing,
        swapV = Nothing,
        tanV = Nothing,
        tanhV = Nothing,
        timesV = Nothing,
        traverseV = Nothing,
        uncurryV = Nothing
      }
  
  lookupName ::
    Plugins.ModuleName -> (String -> Plugins.OccName) -> String -> CoreM (Maybe Plugins.Name)
  lookupName modu mkOcc str = do
    hscEnv <- Plugins.getHscEnv
    Plugins.liftIO
      . fmap (fmap fst)
      . Plugins.lookupRdrNameInModuleForPlugins hscEnv modu
      . Plugins.Unqual
      $ mkOcc str
  
  nameFromStrings :: String -> String -> Lookup Plugins.Name
  nameFromStrings modu str =
    let mod = Plugins.mkModuleName modu
        thName = TH.mkName $ modu <> "." <> str
     in Parallel
          ( ExceptT
              (maybe (Left . pure $ MissingName thName) pure <$> lookupName mod Plugins.mkVarOcc str)
          )
  
  -- | This is still needed for @Categorifier.Core.categorifyRules@. Apparently @thNameToGhcName@
  -- can't load a @TH.Name@ made by @TH.mkName@, unless we specify the package when loading the name.
  nameFromText :: Text -> Lookup Plugins.Name
  nameFromText =
    uncurry nameFromStrings
      . bimap (Text.unpack . Text.dropWhileEnd (== '.')) Text.unpack
      . Text.breakOnEnd "."
  
  lookupRdr :: (Plugins.Name -> CoreM a) -> TH.Name -> CoreM (Maybe a)
  lookupRdr mkThing = traverse mkThing <=< Plugins.thNameToGhcName
  
  findTHName :: TH.Name -> Lookup Plugins.Name
  findTHName tn =
    Parallel
      ( ExceptT
          (maybe (Left . pure $ MissingName tn) pure <$> Plugins.thNameToGhcName tn)
      )
  
  findDataCon :: TH.Name -> Lookup Plugins.DataCon
  findDataCon tn =
    Parallel
      ( ExceptT
          ( maybe (Left . pure $ MissingDataCon tn) pure
              <$> lookupRdr Plugins.lookupDataCon tn
          )
      )
  
  -- | A helper for building `Hierarchy`s, also useful for looking up other `Plugins.Id`s in the
  --   appropriate context.
  findId :: TH.Name -> Lookup Plugins.Id
  findId tn =
    Parallel
      ( ExceptT
          ( maybe (Left . pure $ MissingId tn) pure
              <$> lookupRdr Plugins.lookupId tn
          )
      )
  
  findTyCon :: TH.Name -> Lookup Plugins.TyCon
  findTyCon tn =
    Parallel
      ( ExceptT
          ( maybe (Left . pure $ MissingTyCon tn) pure
              <$> lookupRdr Plugins.lookupTyCon tn
          )
      )
  
  identifier :: TH.Name -> Lookup CoreExpr
  identifier = fmap Plugins.Var . findId
  
  -- | Very much like `mkMethodApps`, but as a function is not a member of a type class, there are no
  --   class parameters to apply (or class dictionary to resolve).
  mkFunctionApps ::
    (Functor f) =>
    -- | The dictionary applicator
    (CoreExpr -> f CoreExpr) ->
    -- | The function
    CoreExpr ->
    -- | The type arguments
    [Type] ->
    -- | The term arguments
    [CoreExpr] ->
    f CoreExpr
  mkFunctionApps onDict fn tys terms =
    fmap (`Plugins.mkCoreApps` terms) . onDict $ Plugins.mkTyApps fn tys
  
  -- | Applies all of the arguments (types and terms) to a type class method. It's structured in a
  --   particular way. E.g., given a class like
  --
  --   >>> class Foldable t where
  --   >>>   foldMap :: Monoid m => (a -> m) -> t a -> m
  --
  --   we need to do a few things in the right order:
  -- 1. apply the type parameters in the class declaration (@t@),
  -- 2. resolve the dictionary for the type class itself (@Foldable t@),
  -- 3. apply the type parameters on the method (@m@ and @a@),
  -- 4. resolve any constraint dictionaries on the method (@`Monoid` m@), and finally
  -- 5. apply the term parameters on the method (values with types @(a -> m)@ and @t a@).
  --
  --   This function automatically handles all the dictionary resolution (via the @onDict@ argument),
  --   but uses the split in the `Type` lists to know when to do the resolution. So, a call to
  --   @foldMap@ would look something like @`mkMethodApps` onDict [t] [m, a] [fn, ta]@.
  --
  --  __NB__: The types as printed in places like [Haddock](https://www.haskell.org/haddock/) and by
  --         `Plugins.Outputable` are misleading. They will show you things like
  --          @forall t m a. (Foldable t, `Monoid` m) => (a -> m) -> t a -> m@, which make
  --          it /look/ like all the dictionary resolution happens after @t@, @m@, and @a@ are
  --          applied. However, doing that can cause the plugin to segfault. Something like
  --          @forall t. Foldable t => forall m a. `Monoid` m => (a -> m) -> t a -> m@ would be more
  --          honest, but not what we currently get.
  mkMethodApps ::
    (Monad f) =>
    -- | The dictionary applicator
    (CoreExpr -> f CoreExpr) ->
    -- | The type class method
    CoreExpr ->
    -- | The type arguments for the type class itself
    [Type] ->
    -- | The type arguments on the method
    [Type] ->
    -- | The term arguments
    [CoreExpr] ->
    f CoreExpr
  mkMethodApps onDict = mkMethodApps' onDict onDict
  
  -- | Like `mkMethodApps`, but takes separate dictionary applicators for class constraints
  -- and method constraints.
  mkMethodApps' ::
    (Monad f) =>
    -- | The dictionary applicator for class constraints
    (CoreExpr -> f CoreExpr) ->
    -- | The dictionary applicator for method constraints
    (CoreExpr -> f CoreExpr) ->
    -- | The type class method
    CoreExpr ->
    -- | The type arguments for the type class itself
    [Type] ->
    -- | The type arguments on the method
    [Type] ->
    -- | The term arguments
    [CoreExpr] ->
    f CoreExpr
  mkMethodApps' onDictCls onDictMeth fn tc tys terms = do
    method <- onDictCls $ Plugins.mkTyApps fn tc
    mkFunctionApps onDictMeth method tys terms
  
  -- | A hierarchy using only type classes available in @base@.
  --
  --  __TODO__: This could generalize `CategoryStack` to @`Monad` f => f@, but can't currently
  --            dynamically load a parameterized type successfully.
  baseHierarchy :: Lookup (Hierarchy CategoryStack)
  baseHierarchy = do
    absV <- closedUnaryOp 'Prelude.abs
    abstCV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        rep <- findTyCon ''Categorifier.Client.Rep
        op <- identifier 'Categorifier.Client.abst
        pure $ \onDict cat a ->
          mkMethodApps onDict arr [cat] [Plugins.mkTyConApp rep [a], a] . pure
            =<< mkMethodApps onDict op [a] [] []
    acosV <- closedUnaryOp 'Numeric.acos
    acoshV <- closedUnaryOp 'Numeric.acosh
    andV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        uncur <- identifier 'Data.Tuple.uncurry
        op <- identifier '(GHC.Classes.&&)
        pure
          ( \onDict cat -> do
              op' <- mkFunctionApps onDict op [] []
              uncur' <-
                mkFunctionApps onDict uncur [Plugins.boolTy, Plugins.boolTy, Plugins.boolTy] [op']
              mkMethodApps
                onDict
                arr
                [cat]
                [Plugins.mkBoxedTupleTy [Plugins.boolTy, Plugins.boolTy], Plugins.boolTy]
                [uncur']
          )
    apV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        uncur <- identifier 'Data.Tuple.uncurry
        op <- identifier '(Control.Applicative.<*>)
        pure
          ( \onDict cat f a b -> do
              let fa = Plugins.mkAppTy f a
                  fb = Plugins.mkAppTy f b
                  ffun = Plugins.mkAppTy f (Plugins.mkAppTys Plugins.properFunTy [a, b])
              op' <- mkMethodApps onDict op [f] [a, b] []
              uncur' <- mkFunctionApps onDict uncur [ffun, fa, fb] [op']
              mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [ffun, fa], fb] [uncur']
          )
    appendV <- closedBinaryOp '(GHC.Base.<>)
    applyV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier '(Data.Function.$)
        uncur <- identifier 'Data.Tuple.uncurry
        pure $
          \onDict cat a b -> do
            let fun = Plugins.mkAppTys Plugins.properFunTy [a, b]
            op' <- mkFunctionApps onDict op [Plugins.liftedRepTy, a, b] []
            uncur' <- mkFunctionApps onDict uncur [fun, a, b] [op']
            mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [fun, a], b] [uncur']
    let apply2V = Nothing
    arctan2V <- closedBinaryOp 'GHC.Float.atan2
    asinV <- closedUnaryOp 'Numeric.asin
    asinhV <- closedUnaryOp 'Numeric.asinh
    atanV <- closedUnaryOp 'Numeric.atan
    atanhV <- closedUnaryOp 'Numeric.atanh
    bindV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier '(Control.Monad.>>=)
        uncur <- identifier 'Data.Tuple.uncurry
        pure $
          \onDict cat m a b -> do
            let ma = Plugins.mkAppTy m a
                mb = Plugins.mkAppTy m b
                fun = Plugins.mkAppTys Plugins.properFunTy [a, mb]
            op' <- mkMethodApps onDict op [m] [a, b] []
            uncur' <- mkFunctionApps onDict uncur [ma, fun, mb] [op']
            mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [ma, fun], mb] [uncur']
    bottomV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'GHC.Err.undefined
        pure $ \onDict cat a b ->
          mkMethodApps onDict arr [cat] [a, b] . pure
            =<< mkFunctionApps onDict op [Plugins.liftedRepTy, Plugins.funTy a b] []
    coerceV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Unsafe.Coerce.unsafeCoerce
        pure $ \onDict cat from to ->
          mkMethodApps onDict arr [cat] [from, to] . pure =<< mkFunctionApps onDict op [from, to] []
    compareV <- binaryOp (Just $ Plugins.mkTyConTy Plugins.orderingTyCon) 'GHC.Classes.compare
    composeV <-
      pure <$> do
        fn <- identifier '(Control.Category..)
        pure $ \onDict cat a b c -> mkMethodApps onDict fn [Plugins.typeKind a, cat] [b, c, a] []
    let compose2V = Nothing
    constV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Data.Function.const
        pure $
          \onDict cat a b ->
            -- Builds a lambda expecting the expression we want to return before applying `arr`. I.e.,
            -- @\bang -> arr (const bang) :: b -> cat a b@.
            let v = Plugins.mkSysLocal (Plugins.fsLit "bang") (Plugins.mkBuiltinUnique 17) b
             in Plugins.Lam v
                  <$> ( mkMethodApps onDict arr [cat] [a, b] . pure
                          =<< mkFunctionApps onDict op [b, a] [Plugins.Var v]
                      )
    let constraintV = Nothing
    cosV <- closedUnaryOp 'Numeric.cos
    coshV <- closedUnaryOp 'Numeric.cosh
    let curryV = Nothing
    distlV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Categorifier.Core.Base.distlB
        eith <- findTyCon ''Data.Either.Either
        pure $ \onDict cat a b c ->
          mkMethodApps
            onDict
            arr
            [cat]
            [ Plugins.mkBoxedTupleTy [a, Plugins.mkTyConApp eith [b, c]],
              Plugins.mkTyConApp eith [Plugins.mkBoxedTupleTy [a, b], Plugins.mkBoxedTupleTy [a, c]]
            ]
            . pure
            =<< mkFunctionApps onDict op [Plugins.mkTyConTy eith, a, b, c] []
    divV <- closedBinaryOp 'GHC.Real.div
    divideV <- closedBinaryOp '(Prelude./)
    doubleToFloatV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'GHC.Float.double2Float
        pure (\onDict cat -> mkMethodApps onDict arr [cat] [Plugins.doubleTy, Plugins.floatTy] [op])
    equalV <- binaryRel '(GHC.Classes.==)
    evenV <- unaryRel 'GHC.Real.even
    exlV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Data.Tuple.fst
        pure $ \onDict cat a b ->
          mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [a, b], a] . pure
            =<< mkFunctionApps onDict op [a, b] []
    expV <- closedUnaryOp 'Numeric.exp
    exrV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Data.Tuple.snd
        pure $ \onDict cat a b ->
          mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [a, b], b] . pure
            =<< mkFunctionApps onDict op [a, b] []
    fixV <-
      pure <$> do
        fn <- identifier 'Categorifier.Core.Base.fixB
        pure (\onDict cat a x -> mkFunctionApps onDict fn [cat, a, x] [])
    floatToDoubleV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'GHC.Float.float2Double
        pure (\onDict cat -> mkMethodApps onDict arr [cat] [Plugins.floatTy, Plugins.doubleTy] [op])
    let fmodV = Nothing
    forkV <-
      pure <$> do
        fn <- identifier '(Control.Arrow.&&&)
        pure (\onDict cat a b c -> mkMethodApps onDict fn [cat] [a, b, c] [])
    fpIsNegativeZeroV <- unaryRel 'GHC.Float.isNegativeZero
    fpIsInfiniteV <- unaryRel 'GHC.Float.isInfinite
    let fpIsFiniteV = Nothing
    fpIsNaNV <- unaryRel 'GHC.Float.isNaN
    fpIsDenormalV <- unaryRel 'GHC.Float.isDenormalized
    fromIntegerV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Prelude.fromInteger
        int <- findTyCon ''Prelude.Integer
        pure $ \onDict cat a ->
          mkMethodApps onDict arr [cat] [Plugins.mkTyConTy int, a] . pure
            =<< mkFunctionApps onDict op [a] []
    fromIntegralV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'GHC.Real.fromIntegral
        pure $ \onDict cat a b ->
          mkMethodApps onDict arr [cat] [a, b] . pure =<< mkFunctionApps onDict op [a, b] []
    geV <- binaryRel '(GHC.Classes.>=)
    gtV <- binaryRel '(GHC.Classes.>)
    idV <-
      pure <$> do
        fn <- identifier 'Control.Category.id
        pure (\onDict cat a -> mkMethodApps onDict fn [Plugins.typeKind a, cat] [a] [])
    ifV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Categorifier.Core.Base.ifThenElseB
        pure $ \onDict cat a ->
          mkMethodApps
            onDict
            arr
            [cat]
            [Plugins.mkBoxedTupleTy [Plugins.boolTy, Plugins.mkBoxedTupleTy [a, a]], a]
            . pure
            =<< mkFunctionApps onDict op [a] []
    inlV <- eitherOp 'Data.Either.Left const
    inrV <- eitherOp 'Data.Either.Right (\_ x -> x)
    joinV <-
      pure <$> do
        fn <- identifier '(Control.Arrow.|||)
        pure (\onDict cat a1 a2 b -> mkMethodApps onDict fn [cat] [a1, b, a2] [])
    lassocV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Categorifier.Core.Base.lassocB
        pure $ \onDict cat a b c ->
          mkMethodApps
            onDict
            arr
            [cat]
            [ Plugins.mkBoxedTupleTy [a, Plugins.mkBoxedTupleTy [b, c]],
              Plugins.mkBoxedTupleTy [Plugins.mkBoxedTupleTy [a, b], c]
            ]
            . pure
            =<< mkFunctionApps onDict op [a, b, c] []
    leV <- binaryRel '(GHC.Classes.<=)
    let liftA2V = Nothing
    logV <- closedUnaryOp 'Numeric.log
    ltV <- binaryRel '(GHC.Classes.<)
    let mapV = Nothing
    maxV <- closedBinaryOp 'Prelude.max
    let maximumV = Nothing
    minV <- closedBinaryOp 'Prelude.min
    let minimumV = Nothing
    minusV <- closedBinaryOp '(Prelude.-)
    modV <- closedBinaryOp 'GHC.Real.mod
    let nativeV = Nothing
    negateV <- closedUnaryOp 'Prelude.negate
    let indexV = Nothing
    realToFracV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'GHC.Real.realToFrac
        pure $ \onDict cat a b ->
          mkMethodApps onDict arr [cat] [a, b] . pure =<< mkFunctionApps onDict op [a, b] []
    let tabulateV = Nothing
    notV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Data.Bool.not
        pure (\onDict cat -> mkMethodApps onDict arr [cat] [Plugins.boolTy, Plugins.boolTy] [op])
    notEqualV <- binaryRel '(GHC.Classes./=)
    oddV <- unaryRel 'GHC.Real.odd
    orV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        uncur <- identifier 'Data.Tuple.uncurry
        op <- identifier '(GHC.Classes.||)
        pure
          ( \onDict cat -> do
              op' <- mkFunctionApps onDict op [] []
              uncur' <-
                mkFunctionApps onDict uncur [Plugins.boolTy, Plugins.boolTy, Plugins.boolTy] [op']
              mkMethodApps
                onDict
                arr
                [cat]
                [Plugins.mkBoxedTupleTy [Plugins.boolTy, Plugins.boolTy], Plugins.boolTy]
                [uncur']
          )
    plusV <- closedBinaryOp '(Prelude.+)
    pointV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Control.Applicative.pure
        pure $ \onDict cat f a ->
          mkMethodApps onDict arr [cat] [a, Plugins.mkAppTy f a] . pure
            =<< mkMethodApps onDict op [f] [a] []
    powV <- closedBinaryOp '(Numeric.**)
    let powIV = Nothing
    powIntV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        uncur <- identifier 'Data.Tuple.uncurry
        op <- identifier '(GHC.Real.^)
        pure $ \onDict cat a -> do
          op' <- mkFunctionApps onDict op [a, Plugins.intTy] []
          uncur' <- mkFunctionApps onDict uncur [a, Plugins.intTy, a] [op']
          mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [a, Plugins.intTy], a] [uncur']
    quotV <- closedBinaryOp 'GHC.Real.quot
    rassocV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Categorifier.Core.Base.rassocB
        pure $ \onDict cat a b c ->
          mkMethodApps
            onDict
            arr
            [cat]
            [ Plugins.mkBoxedTupleTy [Plugins.mkBoxedTupleTy [a, b], c],
              Plugins.mkBoxedTupleTy [a, Plugins.mkBoxedTupleTy [b, c]]
            ]
            . pure
            =<< mkFunctionApps onDict op [a, b, c] []
    recipV <- closedUnaryOp 'Prelude.recip
    remV <- closedBinaryOp 'GHC.Real.rem
    reprCV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        rep <- findTyCon ''Categorifier.Client.Rep
        op <- identifier 'Categorifier.Client.repr
        pure $ \onDict cat a ->
          mkMethodApps onDict arr [cat] [a, Plugins.mkTyConApp rep [a]] . pure
            =<< mkMethodApps onDict op [a] [] []
    let sequenceAV = Nothing
    signumV <- closedUnaryOp 'Prelude.signum
    sinV <- closedUnaryOp 'Numeric.sin
    sinhV <- closedUnaryOp 'Numeric.sinh
    sqrtV <- closedUnaryOp 'Numeric.sqrt
    strengthV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Categorifier.Core.Base.strengthB
        pure $ \onDict cat f a b ->
          mkMethodApps
            onDict
            arr
            [cat]
            [ Plugins.mkBoxedTupleTy [a, Plugins.mkAppTy f b],
              Plugins.mkAppTy f (Plugins.mkBoxedTupleTy [a, b])
            ]
            . pure
            =<< mkFunctionApps onDict op [f, a, b] []
    sumV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Data.Foldable.sum
        pure $ \onDict cat f a -> do
          mkMethodApps onDict arr [cat] [f, a] . pure
            =<< mkMethodApps onDict op [f] [a] []
    swapV <-
      pure <$> do
        arr <- identifier 'Control.Arrow.arr
        op <- identifier 'Data.Tuple.swap
        pure $ \onDict cat a b ->
          mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [a, b], Plugins.mkBoxedTupleTy [b, a]]
            . pure
            =<< mkFunctionApps onDict op [a, b] []
    tanV <- closedUnaryOp 'Numeric.tan
    tanhV <- closedUnaryOp 'Numeric.tanh
    timesV <- closedBinaryOp '(Prelude.*)
    let traverseV = Nothing
    uncurryV <-
      pure <$> do
        fn <- identifier 'Categorifier.Core.Base.uncurryB
        pure (\onDict cat a b c -> mkFunctionApps onDict fn [cat, a, b, c] [])
    pure Hierarchy {..}
    where
      unaryRel = unaryOp (Just Plugins.boolTy)
      binaryRel = binaryOp (Just Plugins.boolTy)
      closedUnaryOp = unaryOp Nothing
      closedBinaryOp = binaryOp Nothing
      unaryOp mbResTy name =
        pure <$> do
          arr <- identifier 'Control.Arrow.arr
          op <- identifier name
          pure $ \onDict cat a -> do
            let resTy = fromMaybe a mbResTy
            mkMethodApps onDict arr [cat] [a, resTy] . pure
              =<< mkMethodApps onDict op [a] [] []
      binaryOp mbResTy name =
        pure <$> do
          arr <- identifier 'Control.Arrow.arr
          uncur <- identifier 'Data.Tuple.uncurry
          op <- identifier name
          pure $ \onDict cat a -> do
            let resTy = fromMaybe a mbResTy
            op' <- mkMethodApps onDict op [a] [] []
            uncur' <- mkFunctionApps onDict uncur [a, a, resTy] [op']
            mkMethodApps onDict arr [cat] [Plugins.mkBoxedTupleTy [a, a], resTy] [uncur']
      eitherOp opName select =
        pure <$> do
          arr <- identifier 'Control.Arrow.arr
          eith <- findTyCon ''Data.Either.Either
          op <- Plugins.Var . Plugins.dataConWorkId <$> findDataCon opName
          pure $ \onDict cat a b ->
            mkMethodApps onDict arr [cat] [select a b, Plugins.mkTyConApp eith [a, b]] . pure
              =<< mkFunctionApps onDict op [a, b] []
  
  data IntConstructor = IntConstructor
    { intConstructorSize :: Integer,
      intConstructorSigned :: Bool,
      intConstructorTyCon :: Plugins.TyCon,
      intConstructorDataCon :: Plugins.DataCon,
      intConstructorNarrowOp :: Maybe Plugins.PrimOp
    }
  
  intConstructorToOpTyPair ::
    IntConstructor ->
    Maybe (Plugins.PrimOp, Plugins.TyCon)
  intConstructorToOpTyPair IntConstructor {..} =
    (,intConstructorTyCon) <$> intConstructorNarrowOp
  
  intConstructorToBoxer ::
    IntConstructor ->
    (Plugins.TyCon, Plugins.DataCon)
  intConstructorToBoxer IntConstructor {..} =
    (intConstructorTyCon, intConstructorDataCon)
  
  getIntegerConstructors :: Lookup [IntConstructor]
  getIntegerConstructors = traverse mkIntCons ints
    where
      mkIntCons ::
        (Integer, Bool, TH.Name, TH.Name, Maybe Plugins.PrimOp) ->
        Lookup IntConstructor
      mkIntCons (i, s, t, d, n) =
        (\tc dc -> IntConstructor i s tc dc n) <$> findTyCon t <*> findDataCon d
      ints =
        -- (size, is signed, module, boxed type, boxing data con, narrowing op)
        [ (8, True, ''GHC.Int.Int8, 'GHC.Int.I8#, pure Plugins.Narrow8IntOp),
          (16, True, ''GHC.Int.Int16, 'GHC.Int.I16#, pure Plugins.Narrow16IntOp),
          (32, True, ''GHC.Int.Int32, 'GHC.Int.I32#, pure Plugins.Narrow32IntOp),
          (64, True, ''GHC.Int.Int64, 'GHC.Int.I64#, Nothing),
          (toInteger $ finiteBitSize (0 :: Int), True, ''GHC.Int.Int, 'GHC.Int.I#, Nothing),
          (8, False, ''GHC.Word.Word8, 'GHC.Word.W8#, pure Plugins.Narrow8WordOp),
          (16, False, ''GHC.Word.Word16, 'GHC.Word.W16#, pure Plugins.Narrow16WordOp),
          (32, False, ''GHC.Word.Word32, 'GHC.Word.W32#, pure Plugins.Narrow32WordOp),
          (64, False, ''GHC.Word.Word64, 'GHC.Word.W64#, Nothing),
          (toInteger $ finiteBitSize (0 :: Word), False, ''GHC.Word.Word, 'GHC.Word.W#, Nothing)
        ]
  
  newtype GetTagInfo = GetTagInfo
    { getTagId :: Plugins.Id
    }
  
  getGetTagInfo :: Lookup GetTagInfo
  getGetTagInfo = GetTagInfo <$> findId 'GHC.Base.getTag
  
  data BaseIdentifiers = BaseIdentifiers
    { baseIntConstructors :: [IntConstructor],
      baseGetTag :: GetTagInfo
    }
  
  getBaseIdentifiers :: Lookup BaseIdentifiers
  getBaseIdentifiers = do
    baseIntConstructors <- getIntegerConstructors
    baseGetTag <- getGetTagInfo
    pure BaseIdentifiers {..}
  