    {-# LANGUAGE PackageImports #-}
    {-# LANGUAGE AllowAmbiguousTypes       #-}
    {-# LANGUAGE DataKinds                 #-}
    {-# LANGUAGE FlexibleContexts          #-}
    {-# LANGUAGE FlexibleInstances         #-}
    {-# LANGUAGE MultiParamTypeClasses     #-}
    {-# LANGUAGE NoMonomorphismRestriction #-}
    {-# LANGUAGE PolyKinds                 #-}
    {-# LANGUAGE Rank2Types                #-}
    {-# LANGUAGE ScopedTypeVariables       #-}
    {-# LANGUAGE TypeApplications          #-}
    {-# LANGUAGE TypeFamilies              #-}
    {-# LANGUAGE TypeOperators             #-}
    {-# LANGUAGE UndecidableInstances      #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Generics.Product.Subtype
    -- Copyright   :  (C) 2020 Csongor Kiss
    -- License     :  BSD3
    -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -- Structural subtype relationships between product types.
    --
    -----------------------------------------------------------------------------

    module Data.Generics.Product.Subtype
      ( -- *Lenses
        --
        -- $setup
        Subtype (..)
      ) where

    import "this" Data.Generics.Internal.VL.Lens as VL

    import "generic-lens-core" Data.Generics.Internal.Void
    import qualified "generic-lens-core" Data.Generics.Product.Internal.Subtype as Core

    import GHC.Generics (Generic (to, from) )

    -- $setup
    -- == /Running example:/
    --
    -- >>> :set -XTypeApplications
    -- >>> :set -XDataKinds
    -- >>> :set -XDeriveGeneric
    -- >>> :set -XDuplicateRecordFields
    -- >>> import GHC.Generics
    -- >>> :m +Data.Generics.Internal.VL.Lens
    -- >>> :{
    -- data Human = Human
    --   { name    :: String
    --   , age     :: Int
    --   , address :: String
    --   }
    --   deriving (Generic, Show)
    -- data Animal = Animal
    --   { name    :: String
    --   , age     :: Int
    --   }
    --   deriving (Generic, Show)
    -- human :: Human
    -- human = Human "Tunyasz" 50 "London"
    -- :}

    -- |Structural subtype relationship
    --
    -- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of
    -- those of @sup@.
    --
    class Subtype sup sub where
      -- |Structural subtype lens. Given a subtype relationship @sub :< sup@,
      --  we can focus on the @sub@ structure of @sup@.
      --
      -- >>> human ^. super @Animal
      -- Animal {name = "Tunyasz", age = 50}
      --
      -- >>> set (super @Animal) (Animal "dog" 10) human
      -- Human {name = "dog", age = 10, address = "London"}
      super  :: VL.Lens sub sub sup sup
      super
        = (sub -> sup) -> (sub -> sup -> sub) -> Lens sub sub sup sup
    forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
    VL.lens sub -> sup
    forall sup sub. Subtype sup sub => sub -> sup
    upcast ((sup -> sub -> sub) -> sub -> sup -> sub
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip sup -> sub -> sub
    forall sup sub. Subtype sup sub => sup -> sub -> sub
    smash)
      {-# INLINE super #-}

      -- |Cast the more specific subtype to the more general supertype
      --
      -- >>> upcast human :: Animal
      -- Animal {name = "Tunyasz", age = 50}
      --
      -- >>> upcast (upcast human :: Animal) :: Human
      -- ...
      -- ... The type 'Animal' is not a subtype of 'Human'.
      -- ... The following fields are missing from 'Animal':
      -- ... address
      -- ...
      upcast :: sub -> sup
      upcast sub
    s = sub
    s sub -> ((sup -> Const sup sup) -> sub -> Const sup sub) -> sup
    forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
    ^. forall sup sub. Subtype sup sub => Lens sub sub sup sup
    super @sup
      {-# INLINE upcast #-}

      -- |Plug a smaller structure into a larger one
      --
      -- >>> smash (Animal "dog" 10) human
      -- Human {name = "dog", age = 10, address = "London"}
      smash  :: sup -> sub -> sub
      smash = Lens sub sub sup sup -> sup -> sub -> sub
    forall s t a b. Lens s t a b -> b -> s -> t
    VL.set (forall sup sub. Subtype sup sub => Lens sub sub sup sup
    super @sup)
      {-# INLINE smash #-}

      {-# MINIMAL super | smash, upcast #-}

    instance Core.Context a b => Subtype b a where
        smash :: b -> a -> a
    smash b
    p a
    b = Rep a (ZonkAny 1) -> a
    forall a x. Generic a => Rep a x -> a
    forall x. Rep a x -> a
    to (Rep a (ZonkAny 1) -> a) -> Rep a (ZonkAny 1) -> a
    forall a b. (a -> b) -> a -> b
    $ Rep b (ZonkAny 1) -> Rep a (ZonkAny 1) -> Rep a (ZonkAny 1)
    forall p. Rep b p -> Rep a p -> Rep a p
    forall {k} (sub :: k -> *) (sup :: k -> *) (p :: k).
    GSmash sub sup =>
    sup p -> sub p -> sub p
    Core.gsmash (b -> Rep b (ZonkAny 1)
    forall x. b -> Rep b x
    forall a x. Generic a => a -> Rep a x
    from b
    p) (a -> Rep a (ZonkAny 1)
    forall x. a -> Rep a x
    forall a x. Generic a => a -> Rep a x
    from a
    b)
        upcast :: a -> b
    upcast    = Rep b (ZonkAny 0) -> b
    forall a x. Generic a => Rep a x -> a
    forall x. Rep b x -> b
    to (Rep b (ZonkAny 0) -> b) -> (a -> Rep b (ZonkAny 0)) -> a -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Rep a (ZonkAny 0) -> Rep b (ZonkAny 0)
    forall p. Rep a p -> Rep b p
    forall (sub :: * -> *) (sup :: * -> *) p.
    GUpcast sub sup =>
    sub p -> sup p
    Core.gupcast (Rep a (ZonkAny 0) -> Rep b (ZonkAny 0))
    -> (a -> Rep a (ZonkAny 0)) -> a -> Rep b (ZonkAny 0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Rep a (ZonkAny 0)
    forall x. a -> Rep a x
    forall a x. Generic a => a -> Rep a x
    from

    instance {-# OVERLAPPING #-} Subtype a a where
      super :: Lens a a a a
    super = (a -> f a) -> a -> f a
    forall a. a -> a
    id

    -- | Uncluttering type signatures (see 'Void')
    --
    -- >>> :t +d super
    -- super
    --   :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub
    instance {-# OVERLAPPING #-} Subtype a Void where
      super :: Lens Void Void a a
    super = (a -> f a) -> Void -> f Void
    forall a. HasCallStack => a
    undefined

    -- | Uncluttering type signatures (see 'Void')
    --
    -- >>> :t +d super @Int
    -- super @Int
    --   :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub
    instance {-# OVERLAPPING #-} Subtype Void a where
      super :: Lens a a Void Void
    super = (Void -> f Void) -> a -> f a
    forall a. HasCallStack => a
    undefined