{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE UndecidableInstances  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Generics.Sum.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 sum types.
--
-----------------------------------------------------------------------------

module Data.Generics.Sum.Subtype
  ( -- *Prisms
    --
    -- $setup
    AsSubtype (..)
  ) where

import "this" Data.Generics.Internal.VL.Prism

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


-- $setup
-- == /Running example:/
--
-- >>> :set -XTypeApplications
-- >>> :set -XDataKinds
-- >>> :set -XDeriveGeneric
-- >>> import GHC.Generics
-- >>> import Control.Lens
-- >>> :{
-- data Animal
--   = Dog Dog
--   | Cat Name Age
--   | Duck Age
--   deriving (Generic, Show)
-- data FourLeggedAnimal
--   = Dog4 Dog
--   | Cat4 Name Age
--   deriving (Generic, Show)
-- data Dog = MkDog
--   { name :: Name
--   , age  :: Age
--   }
--   deriving (Generic, Show)
-- type Name = String
-- type Age  = Int
-- dog, cat, duck :: Animal
-- dog = Dog (MkDog "Shep" 3)
-- cat = Cat "Mog" 5
-- duck = Duck 2
-- dog4, cat4 :: FourLeggedAnimal
-- dog4 = Dog4 (MkDog "Snowy" 4)
-- cat4 = Cat4 "Garfield" 6
-- :}

-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum
--  'Sup' if a value of 'Sub' can be given (modulo naming of constructors)
--  whenever a value of 'Sup' is expected. In the running example for instance,
--  'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can
--  be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to
--  'Cat').
class AsSubtype sub sup where
  -- |A prism that captures structural subtyping. Allows a substructure to be
  --  injected (upcast) into a superstructure or a superstructure to be downcast
  --  into a substructure (which may fail).
  --
  --  >>> _Sub # dog4 :: Animal
  --  Dog (MkDog {name = "Snowy", age = 4})
  --
  --  >>> cat ^? _Sub :: Maybe FourLeggedAnimal
  --  Just (Cat4 "Mog" 5)
  --
  --  >>> duck ^? _Sub :: Maybe FourLeggedAnimal
  --  Nothing
  _Sub :: Prism' sup sub
  _Sub = (sub -> sup) -> (sup -> Either sup sub) -> Prism sup sup sub sub
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism sub -> sup
forall sub sup. AsSubtype sub sup => sub -> sup
injectSub (\sup
i -> Either sup sub
-> (sub -> Either sup sub) -> Maybe sub -> Either sup sub
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (sup -> Either sup sub
forall a b. a -> Either a b
Left sup
i) sub -> Either sup sub
forall a b. b -> Either a b
Right (sup -> Maybe sub
forall sub sup. AsSubtype sub sup => sup -> Maybe sub
projectSub sup
i))
  {-# INLINE _Sub #-}

  -- |Injects a subtype into a supertype (upcast).
  injectSub  :: sub -> sup
  injectSub
    = Prism sup sup sub sub -> sub -> sup
forall s t a b. Prism s t a b -> b -> t
build (AsSubtype sub sup => Prism sup sup sub sub
forall sub sup. AsSubtype sub sup => Prism sup sup sub sub
_Sub @sub @sup)

  -- |Projects a subtype from a supertype (downcast).
  projectSub :: sup -> Maybe sub
  projectSub
    = (sup -> Maybe sub)
-> (sub -> Maybe sub) -> Either sup sub -> Maybe sub
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe sub -> sup -> Maybe sub
forall a b. a -> b -> a
const Maybe sub
forall a. Maybe a
Nothing) sub -> Maybe sub
forall a. a -> Maybe a
Just (Either sup sub -> Maybe sub)
-> (sup -> Either sup sub) -> sup -> Maybe sub
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism sup sup sub sub -> sup -> Either sup sub
forall s t a b. Prism s t a b -> s -> Either t a
match (AsSubtype sub sup => Prism sup sup sub sub
forall sub sup. AsSubtype sub sup => Prism sup sup sub sub
_Sub @sub @sup)

  {-# MINIMAL (injectSub, projectSub) | _Sub #-}

instance Core.Context sub sup => AsSubtype sub sup where
  _Sub :: p sub (f sub) -> p sup (f sup)
_Sub p sub (f sub)
f = APrism Any sup sup sub sub -> p sub (f sub) -> p sup (f sup)
forall i s t a b. APrism i s t a b -> Prism s t a b
prism2prismvl APrism Any sup sup sub sub
forall sub sup. Context sub sup => Prism' sup sub
Core.derived p sub (f sub)
f
  {-# INLINE _Sub #-}

-- | Reflexive case
--  >>> _Sub # dog :: Animal
--  Dog (MkDog {name = "Shep", age = 3})
instance {-# OVERLAPPING #-} AsSubtype a a where
  _Sub :: p a (f a) -> p a (f a)
_Sub = p a (f a) -> p a (f a)
forall a. a -> a
id
  {-# INLINE _Sub #-}

-- | See Note [Uncluttering type signatures]
--_Sub
--  :: (AsSubtype sub sup, Data.Profunctor.Choice.Choice p,
--      Applicative f) =>
--     p sub (f sub) -> p sup (f sup)
instance {-# OVERLAPPING #-} AsSubtype a Void where
  injectSub :: a -> Void
injectSub = a -> Void
forall a. HasCallStack => a
undefined
  projectSub :: Void -> Maybe a
projectSub = Void -> Maybe a
forall a. HasCallStack => a
undefined

-- | See Note [Uncluttering type signatures]
-- >>> :t +d _Sub @Int
-- _Sub @Int
--   :: (AsSubtype Int sup, Choice p, Applicative f) =>
--      p Int (f Int) -> p sup (f sup)
instance {-# OVERLAPPING #-} AsSubtype Void a where
  injectSub :: Void -> a
injectSub = Void -> a
forall a. HasCallStack => a
undefined
  projectSub :: a -> Maybe Void
projectSub = a -> Maybe Void
forall a. HasCallStack => a
undefined