{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Instances to implement the subtyping hierarchy between optics.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Optics.Internal.Optic.Subtyping where

import GHC.TypeLits (ErrorMessage(..), TypeError)

import Optics.Internal.Optic.TypeLevel
import Optics.Internal.Optic.Types

-- | Subtyping relationship between kinds of optics.
--
-- An instance of @'Is' k l@ means that any @'Optics.Optic.Optic' k@ can be used
-- as an @'Optics.Optic.Optic' l@. For example, we have an @'Is' 'A_Lens'
-- 'A_Traversal'@ instance, but not @'Is' 'A_Traversal' 'A_Lens'@.
--
-- This class needs instances for all possible combinations of tags.
--
class Is k l where
  -- | Witness of the subtyping relationship.
  implies :: (Constraints k p => r) -> (Constraints l p => r)

-- | Every kind of optic can be used as itself.
instance Is k k where
  implies r = r

-- | Overlappable instance for a custom type error.
instance {-# OVERLAPPABLE #-} TypeError
  ('ShowType k ':<>: 'Text " cannot be used as " ':<>: 'ShowType l
   ':$$: 'Text "Perhaps you meant one of these:"
   ':$$: ShowEliminations (EliminationForms k)
  ) => Is k l where
  implies _ = error "unreachable"

type family EliminationForms (k :: OpticKind) where
  EliminationForms An_AffineFold      = AffineFoldEliminations
  EliminationForms An_AffineTraversal = AffineTraversalEliminations
  EliminationForms A_Fold             = FoldEliminations
  EliminationForms A_Getter           = GetterEliminations
  EliminationForms An_Iso             = IsoEliminations
  EliminationForms A_Lens             = LensEliminations
  EliminationForms A_Prism            = PrismEliminations
  EliminationForms A_ReversedLens     = ReviewEliminations
  EliminationForms A_ReversedPrism    = GetterEliminations
  EliminationForms A_Review           = ReviewEliminations
  EliminationForms A_Setter           = SetterEliminations
  EliminationForms A_Traversal        = TraversalEliminations

type AffineFoldEliminations = '( '[ '("preview", "Optics.AffineFold") ]
                               , '[ "(^?)" ])

type AffineTraversalEliminations = AffineFoldEliminations
              `AppendEliminations` SetterEliminations

type FoldEliminations = '( '[ '("traverseOf_", "Optics.Fold")
                            , '("foldMapOf",   "Optics.Fold")
                            , '("toListOf",    "Optics.Fold")
                            ]
                         , '[ "(^..)" ])

type GetterEliminations = '( '[ '("view", "Optics.Getter") ]
                           , '[ "(^.)" ])

type IsoEliminations = GetterEliminations
  `AppendEliminations` ReviewEliminations
  `AppendEliminations` SetterEliminations

type LensEliminations = GetterEliminations
   `AppendEliminations` SetterEliminations

type PrismEliminations = AffineFoldEliminations
    `AppendEliminations` ReviewEliminations
    `AppendEliminations` SetterEliminations

type ReviewEliminations = '( '[ '("review", "Optics.Review") ]
                           , '[ "(#)" ])

type SetterEliminations = '( '[ '("over", "Optics.Setter")
                              , '("set",  "Optics.Setter")
                              ]
                           , '[ "(%~)", "(.~)" ])

type TraversalEliminations = '( '[ '("traverseOf", "Optics.Traversal") ]
                              , '[]) `AppendEliminations` FoldEliminations
                                     `AppendEliminations` SetterEliminations

----------------------------------------

-- BEGIN GENERATED CONTENT

-- An_Iso
instance Is An_Iso             A_ReversedLens     where implies r = r
instance Is An_Iso             A_ReversedPrism    where implies r = r
instance Is An_Iso             A_Prism            where implies r = r
instance Is An_Iso             A_Review           where implies r = r
instance Is An_Iso             A_Lens             where implies r = r
instance Is An_Iso             A_Getter           where implies r = r
instance Is An_Iso             An_AffineTraversal where implies r = r
instance Is An_Iso             An_AffineFold      where implies r = r
instance Is An_Iso             A_Traversal        where implies r = r
instance Is An_Iso             A_Fold             where implies r = r
instance Is An_Iso             A_Setter           where implies r = r
-- A_ReversedLens
instance Is A_ReversedLens     A_Review           where implies r = r
-- A_ReversedPrism
instance Is A_ReversedPrism    A_Getter           where implies r = r
instance Is A_ReversedPrism    An_AffineFold      where implies r = r
instance Is A_ReversedPrism    A_Fold             where implies r = r
-- A_Prism
instance Is A_Prism            A_Review           where implies r = r
instance Is A_Prism            An_AffineTraversal where implies r = r
instance Is A_Prism            An_AffineFold      where implies r = r
instance Is A_Prism            A_Traversal        where implies r = r
instance Is A_Prism            A_Fold             where implies r = r
instance Is A_Prism            A_Setter           where implies r = r
-- A_Lens
instance Is A_Lens             A_Getter           where implies r = r
instance Is A_Lens             An_AffineTraversal where implies r = r
instance Is A_Lens             An_AffineFold      where implies r = r
instance Is A_Lens             A_Traversal        where implies r = r
instance Is A_Lens             A_Fold             where implies r = r
instance Is A_Lens             A_Setter           where implies r = r
-- A_Getter
instance Is A_Getter           An_AffineFold      where implies r = r
instance Is A_Getter           A_Fold             where implies r = r
-- An_AffineTraversal
instance Is An_AffineTraversal An_AffineFold      where implies r = r
instance Is An_AffineTraversal A_Traversal        where implies r = r
instance Is An_AffineTraversal A_Fold             where implies r = r
instance Is An_AffineTraversal A_Setter           where implies r = r
-- An_AffineFold
instance Is An_AffineFold      A_Fold             where implies r = r
-- A_Traversal
instance Is A_Traversal        A_Fold             where implies r = r
instance Is A_Traversal        A_Setter           where implies r = r

-- END GENERATED CONTENT

----------------------------------------

-- | Computes the least upper bound of two optics kinds.
--
-- @Join k l@ represents the least upper bound of an @Optic k@ and an @Optic
-- l@. This means in particular that composition of an @Optic k@ and an @Optic
-- k@ will yield an @Optic (Join k l)@.
--
type family Join (k :: OpticKind) (l :: OpticKind) where
  -- BEGIN GENERATED CONTENT
  -- An_Iso-----
  Join An_Iso             A_ReversedLens     = A_ReversedLens
  Join An_Iso             A_ReversedPrism    = A_ReversedPrism
  Join An_Iso             A_Prism            = A_Prism
  Join An_Iso             A_Review           = A_Review
  Join An_Iso             A_Lens             = A_Lens
  Join An_Iso             A_Getter           = A_Getter
  Join An_Iso             An_AffineTraversal = An_AffineTraversal
  Join An_Iso             An_AffineFold      = An_AffineFold
  Join An_Iso             A_Traversal        = A_Traversal
  Join An_Iso             A_Fold             = A_Fold
  Join An_Iso             A_Setter           = A_Setter

  -- A_ReversedLens-----
  Join A_ReversedLens     An_Iso             = A_ReversedLens
  -- no Join with         A_ReversedPrism
  Join A_ReversedLens     A_Prism            = A_Review
  Join A_ReversedLens     A_Review           = A_Review
  -- no Join with         A_Lens
  -- no Join with         A_Getter
  -- no Join with         An_AffineTraversal
  -- no Join with         An_AffineFold
  -- no Join with         A_Traversal
  -- no Join with         A_Fold
  -- no Join with         A_Setter

  -- A_ReversedPrism-----
  Join A_ReversedPrism    An_Iso             = A_ReversedPrism
  -- no Join with         A_ReversedLens
  Join A_ReversedPrism    A_Prism            = An_AffineFold
  -- no Join with         A_Review
  Join A_ReversedPrism    A_Lens             = A_Getter
  Join A_ReversedPrism    A_Getter           = A_Getter
  Join A_ReversedPrism    An_AffineTraversal = An_AffineFold
  Join A_ReversedPrism    An_AffineFold      = An_AffineFold
  Join A_ReversedPrism    A_Traversal        = A_Fold
  Join A_ReversedPrism    A_Fold             = A_Fold
  -- no Join with         A_Setter

  -- A_Prism-----
  Join A_Prism            An_Iso             = A_Prism
  Join A_Prism            A_ReversedLens     = A_Review
  Join A_Prism            A_ReversedPrism    = An_AffineFold
  Join A_Prism            A_Review           = A_Review
  Join A_Prism            A_Lens             = An_AffineTraversal
  Join A_Prism            A_Getter           = An_AffineFold
  Join A_Prism            An_AffineTraversal = An_AffineTraversal
  Join A_Prism            An_AffineFold      = An_AffineFold
  Join A_Prism            A_Traversal        = A_Traversal
  Join A_Prism            A_Fold             = A_Fold
  Join A_Prism            A_Setter           = A_Setter

  -- A_Review-----
  Join A_Review           An_Iso             = A_Review
  Join A_Review           A_ReversedLens     = A_Review
  -- no Join with         A_ReversedPrism
  Join A_Review           A_Prism            = A_Review
  -- no Join with         A_Lens
  -- no Join with         A_Getter
  -- no Join with         An_AffineTraversal
  -- no Join with         An_AffineFold
  -- no Join with         A_Traversal
  -- no Join with         A_Fold
  -- no Join with         A_Setter

  -- A_Lens-----
  Join A_Lens             An_Iso             = A_Lens
  -- no Join with         A_ReversedLens
  Join A_Lens             A_ReversedPrism    = A_Getter
  Join A_Lens             A_Prism            = An_AffineTraversal
  -- no Join with         A_Review
  Join A_Lens             A_Getter           = A_Getter
  Join A_Lens             An_AffineTraversal = An_AffineTraversal
  Join A_Lens             An_AffineFold      = An_AffineFold
  Join A_Lens             A_Traversal        = A_Traversal
  Join A_Lens             A_Fold             = A_Fold
  Join A_Lens             A_Setter           = A_Setter

  -- A_Getter-----
  Join A_Getter           An_Iso             = A_Getter
  -- no Join with         A_ReversedLens
  Join A_Getter           A_ReversedPrism    = A_Getter
  Join A_Getter           A_Prism            = An_AffineFold
  -- no Join with         A_Review
  Join A_Getter           A_Lens             = A_Getter
  Join A_Getter           An_AffineTraversal = An_AffineFold
  Join A_Getter           An_AffineFold      = An_AffineFold
  Join A_Getter           A_Traversal        = A_Fold
  Join A_Getter           A_Fold             = A_Fold
  -- no Join with         A_Setter

  -- An_AffineTraversal-----
  Join An_AffineTraversal An_Iso             = An_AffineTraversal
  -- no Join with         A_ReversedLens
  Join An_AffineTraversal A_ReversedPrism    = An_AffineFold
  Join An_AffineTraversal A_Prism            = An_AffineTraversal
  -- no Join with         A_Review
  Join An_AffineTraversal A_Lens             = An_AffineTraversal
  Join An_AffineTraversal A_Getter           = An_AffineFold
  Join An_AffineTraversal An_AffineFold      = An_AffineFold
  Join An_AffineTraversal A_Traversal        = A_Traversal
  Join An_AffineTraversal A_Fold             = A_Fold
  Join An_AffineTraversal A_Setter           = A_Setter

  -- An_AffineFold-----
  Join An_AffineFold      An_Iso             = An_AffineFold
  -- no Join with         A_ReversedLens
  Join An_AffineFold      A_ReversedPrism    = An_AffineFold
  Join An_AffineFold      A_Prism            = An_AffineFold
  -- no Join with         A_Review
  Join An_AffineFold      A_Lens             = An_AffineFold
  Join An_AffineFold      A_Getter           = An_AffineFold
  Join An_AffineFold      An_AffineTraversal = An_AffineFold
  Join An_AffineFold      A_Traversal        = A_Fold
  Join An_AffineFold      A_Fold             = A_Fold
  -- no Join with         A_Setter

  -- A_Traversal-----
  Join A_Traversal        An_Iso             = A_Traversal
  -- no Join with         A_ReversedLens
  Join A_Traversal        A_ReversedPrism    = A_Fold
  Join A_Traversal        A_Prism            = A_Traversal
  -- no Join with         A_Review
  Join A_Traversal        A_Lens             = A_Traversal
  Join A_Traversal        A_Getter           = A_Fold
  Join A_Traversal        An_AffineTraversal = A_Traversal
  Join A_Traversal        An_AffineFold      = A_Fold
  Join A_Traversal        A_Fold             = A_Fold
  Join A_Traversal        A_Setter           = A_Setter

  -- A_Fold-----
  Join A_Fold             An_Iso             = A_Fold
  -- no Join with         A_ReversedLens
  Join A_Fold             A_ReversedPrism    = A_Fold
  Join A_Fold             A_Prism            = A_Fold
  -- no Join with         A_Review
  Join A_Fold             A_Lens             = A_Fold
  Join A_Fold             A_Getter           = A_Fold
  Join A_Fold             An_AffineTraversal = A_Fold
  Join A_Fold             An_AffineFold      = A_Fold
  Join A_Fold             A_Traversal        = A_Fold
  -- no Join with         A_Setter

  -- A_Setter-----
  Join A_Setter           An_Iso             = A_Setter
  -- no Join with         A_ReversedLens
  -- no Join with         A_ReversedPrism
  Join A_Setter           A_Prism            = A_Setter
  -- no Join with         A_Review
  Join A_Setter           A_Lens             = A_Setter
  -- no Join with         A_Getter
  Join A_Setter           An_AffineTraversal = A_Setter
  -- no Join with         An_AffineFold
  Join A_Setter           A_Traversal        = A_Setter
  -- no Join with         A_Fold

  -- END GENERATED CONTENT

  -- Every optic kinds can be joined with itself.
  Join k k = k

  -- Everything else is a type error.
  Join k l = TypeError ('ShowType k
                        ':<>: 'Text " cannot be composed with "
                        ':<>: 'ShowType l)