{-# 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 Optics.Core hiding (to)
import Optics.Internal.Optic

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
-- >>> import Optics.Core
-- >>> :{
-- 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  :: 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
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 -> Lens sub sub sup sup -> sup
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall sub. Subtype sup sub => Lens sub sub sup sup
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 k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (forall sub. Subtype sup sub => Lens sub sub sup sup
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 Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Rep a Any -> a
forall a b. (a -> b) -> a -> b
$ Rep b Any -> Rep a Any -> Rep a Any
forall k (sub :: k -> *) (sup :: k -> *) (p :: k).
GSmash sub sup =>
sup p -> sub p -> sub p
Core.gsmash (b -> Rep b Any
forall a x. Generic a => a -> Rep a x
from b
p) (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
b)
    upcast :: a -> b
upcast    = Rep b Any -> b
forall a x. Generic a => Rep a x -> a
to (Rep b Any -> b) -> (a -> Rep b Any) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> Rep b Any
forall (sub :: * -> *) (sup :: * -> *) p.
GUpcast sub sup =>
sub p -> sup p
Core.gupcast (Rep a Any -> Rep b Any) -> (a -> Rep a Any) -> a -> Rep b Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

instance {-# OVERLAPPING #-} Subtype a a where
  super :: Lens a a a a
super = (forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ A_Lens p i (Curry NoIx i) a a a a)
-> Lens a a a a
forall k (is :: IxList) s t a b.
(forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ k p i (Curry is i) s t a b)
-> Optic k is s t a b
Optic forall a. a -> a
forall (p :: * -> * -> * -> *) i.
Profunctor p =>
Optic_ A_Lens p i (Curry NoIx i) a a a a
id

-- | See Note [Uncluttering type signatures]
-- >>> :t super
-- super :: Subtype sup sub => Lens sub sub sup sup
instance {-# OVERLAPPING #-} Subtype a Void where
  super :: Lens Void Void a a
super = Lens Void Void a a
forall a. HasCallStack => a
undefined

-- | See Note [Uncluttering type signatures]
-- >>> :t super @Int
-- super @Int :: Subtype Int sub => Lens sub sub Int Int
instance {-# OVERLAPPING #-} Subtype Void a where
  super :: Lens a a Void Void
super = Lens a a Void Void
forall a. HasCallStack => a
undefined