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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Generics.Sum.Typed
-- Copyright   :  (C) 2020 Csongor Kiss
-- License     :  BSD3
-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Derive constructor-field-type-based prisms generically.
--
-----------------------------------------------------------------------------

module Data.Generics.Sum.Typed
  ( -- *Prisms
    --
    --  $setup
    AsType (..)
  ) where

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

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

-- $setup
-- >>> :set -XTypeApplications
-- >>> :set -XDataKinds
-- >>> :set -XDeriveGeneric
-- >>> import GHC.Generics
-- >>> import Control.Lens
-- >>> :{
-- data Animal
--   = Dog Dog
--   | Cat Name Age
--   | Duck Age
--   | Turtle Age
--   deriving (Generic, Show)
-- data Dog
--   = MkDog
--   { name :: Name
--   , age  :: Age
--   }
--   deriving (Generic, Show)
-- type Name = String
-- newtype Age  = Age Int deriving Show
-- dog, cat, duck :: Animal
-- dog = Dog (MkDog "Shep" (Age 3))
-- cat = Cat "Mog" (Age 5)
-- duck = Duck (Age 2)
-- :}


-- |Sums that have a constructor with a field of the given type.
class AsType a s where
  -- |A prism that projects a constructor uniquely identifiable by the type of
  --  its field. Compatible with the lens package's 'Control.Lens.Prism' type.
  --
  --  >>> dog ^? _Typed @Dog
  --  Just (MkDog {name = "Shep", age = Age 3})
  --  >>> cat ^? _Typed @(Name, Age)
  --  Just ("Mog",Age 5)
  --  >>> dog ^? _Typed @Age
  --  ...
  --  ...
  --  ... The type Animal contains multiple constructors whose fields are of type Age.
  --  ... The choice of constructor is thus ambiguous, could be any of:
  --  ... Duck
  --  ... Turtle
  --  ...
  _Typed :: Prism' s a
  _Typed = (a -> s) -> (s -> Either s a) -> Prism s s a a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism a -> s
forall a s. AsType a s => a -> s
injectTyped (\s
i -> Either s a -> (a -> Either s a) -> Maybe a -> Either s a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (s -> Either s a
forall a b. a -> Either a b
Left s
i) a -> Either s a
forall a b. b -> Either a b
Right (s -> Maybe a
forall a s. AsType a s => s -> Maybe a
projectTyped s
i))
  {-# INLINE _Typed #-}

  -- |Inject by type.
  injectTyped :: a -> s
  injectTyped
    = Prism s s a a -> a -> s
forall s t a b. Prism s t a b -> b -> t
build forall a s. AsType a s => Prism s s a a
Prism s s a a
_Typed

  -- |Project by type.
  projectTyped :: s -> Maybe a
  projectTyped
    = (s -> Maybe a) -> (a -> Maybe a) -> Either s a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> s -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either s a -> Maybe a) -> (s -> Either s a) -> s -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism s s a a -> s -> Either s a
forall s t a b. Prism s t a b -> s -> Either t a
match forall a s. AsType a s => Prism s s a a
Prism s s a a
_Typed

  {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}

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

-- | See Note [Uncluttering type signatures]
-- >>> :t +d _Typed
-- _Typed
--   :: (AsType a s, Choice p, Applicative f) => p a (f a) -> p s (f s)
instance {-# OVERLAPPING #-} AsType a Void where
  _Typed :: p a (f a) -> p Void (f Void)
_Typed = p a (f a) -> p Void (f Void)
forall a. HasCallStack => a
undefined
  injectTyped :: a -> Void
injectTyped = a -> Void
forall a. HasCallStack => a
undefined
  projectTyped :: Void -> Maybe a
projectTyped = Void -> Maybe a
forall a. HasCallStack => a
undefined

-- | See Note [Uncluttering type signatures]
-- >>> :t +d _Typed @Int
-- _Typed @Int
--   :: (AsType Int s, Choice p, Applicative f) =>
--      p Int (f Int) -> p s (f s)
instance {-# OVERLAPPING #-} AsType Void a where
  _Typed :: p Void (f Void) -> p a (f a)
_Typed = p Void (f Void) -> p a (f a)
forall a. HasCallStack => a
undefined
  injectTyped :: Void -> a
injectTyped = Void -> a
forall a. HasCallStack => a
undefined
  projectTyped :: a -> Maybe Void
projectTyped = a -> Maybe Void
forall a. HasCallStack => a
undefined