Generically-derivable mechanism for producing predicates from datatype constructors

Constructor.hs

{-# LANGUAGE DefaultSignatures, DeriveAnyClass, StandaloneDeriving, TypeFamilies, TypeOperators #-}
module Constructor where

import Data.Function (on)
import GHC.Generics
import Prologue

-- | The class of types for which we can determine whether an inhabitant was constructed with some specific constructor.
--
--   Note that the provided instance for functions returning 'HasConstructor' types, @HasConstructor b => HasConstructor (a -> b)@, applies its first argument to 'undefined'. Thus, data types with strict fields cannot safely implement 'HasConstructor' instances, since they would diverge. If you really want to play with fire, then you’ll have to apply the constructors to any strict fields yourself on the left-hand side.
class HasConstructor t where
  type Constructed t :: *
  type instance Constructed t = t

  -- | Given a constructor of @t@, returns a predicate on the constructed type @Constructed t@. For example, the predicate:
  --
  -- > hasConstructor []
  --
  --   is in some sense equivalent to Data.List’s 'null' function.
  --
  --   If @-XDeriveAnyClass@ is enabled, one can derive instances for types with 'Generic' instances. Note that since 'hasConstructor' over an applied type constructor @f a@ does not depend on the existence of a 'HasConstructor' instance for @a@, you may additionally require @-XStandaloneDeriving@ to derive instances over parameterized types.
  hasConstructor :: t -> Constructed t -> Bool
  default hasConstructor :: (Generic t, GHasConstructor (Rep t)) => t -> t -> Bool
  hasConstructor = ghasConstructor `on` from

instance HasConstructor b => HasConstructor (a -> b) where
  type Constructed (a -> b) = Constructed b

  hasConstructor f = hasConstructor (f undefined)

deriving instance HasConstructor (Maybe a)
deriving instance HasConstructor (Either a b)
deriving instance HasConstructor [a]


class GHasConstructor t where
  ghasConstructor :: t a -> t a -> Bool

instance GHasConstructor f => GHasConstructor (M1 D c f) where
  ghasConstructor = ghasConstructor `on` unM1

instance GHasConstructor (M1 C c f) where
  ghasConstructor _ _ = True

instance (GHasConstructor f, GHasConstructor g) => GHasConstructor (f :+: g) where
  ghasConstructor (L1 l1) (L1 l2) = ghasConstructor l1 l2
  ghasConstructor (R1 r1) (R1 r2) = ghasConstructor r1 r2
  ghasConstructor _ _ = False