optics-core-0.4.2: src/Optics/Internal/Optic/Subtyping.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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.
--
-- In presence of a @JoinKinds k l m@ constraint @Optic m@ 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 m@.
--
-- @since 0.4
--
class JoinKinds k l m | k l -> m where
joinKinds :: ((Constraints k p, Constraints l p) => r) -> (Constraints m p => r)
-- BEGIN GENERATED CONTENT
-- An_Iso -----
instance k ~ An_Iso => JoinKinds An_Iso An_Iso k where
joinKinds r = r
instance k ~ A_ReversedLens => JoinKinds An_Iso A_ReversedLens k where
joinKinds r = r
instance k ~ A_ReversedPrism => JoinKinds An_Iso A_ReversedPrism k where
joinKinds r = r
instance k ~ A_Prism => JoinKinds An_Iso A_Prism k where
joinKinds r = r
instance k ~ A_Review => JoinKinds An_Iso A_Review k where
joinKinds r = r
instance k ~ A_Lens => JoinKinds An_Iso A_Lens k where
joinKinds r = r
instance k ~ A_Getter => JoinKinds An_Iso A_Getter k where
joinKinds r = r
instance k ~ An_AffineTraversal => JoinKinds An_Iso An_AffineTraversal k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds An_Iso An_AffineFold k where
joinKinds r = r
instance k ~ A_Traversal => JoinKinds An_Iso A_Traversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds An_Iso A_Fold k where
joinKinds r = r
instance k ~ A_Setter => JoinKinds An_Iso A_Setter k where
joinKinds r = r
-- A_ReversedLens -----
instance k ~ A_ReversedLens => JoinKinds A_ReversedLens A_ReversedLens k where
joinKinds r = r
instance k ~ A_ReversedLens => JoinKinds A_ReversedLens An_Iso k where
joinKinds r = r
-- no JoinKinds A_ReversedLens A_ReversedPrism
instance k ~ A_Review => JoinKinds A_ReversedLens A_Prism k where
joinKinds r = r
instance k ~ A_Review => JoinKinds A_ReversedLens A_Review k where
joinKinds r = r
-- no JoinKinds A_ReversedLens A_Lens
-- no JoinKinds A_ReversedLens A_Getter
-- no JoinKinds A_ReversedLens An_AffineTraversal
-- no JoinKinds A_ReversedLens An_AffineFold
-- no JoinKinds A_ReversedLens A_Traversal
-- no JoinKinds A_ReversedLens A_Fold
-- no JoinKinds A_ReversedLens A_Setter
-- A_ReversedPrism -----
instance k ~ A_ReversedPrism => JoinKinds A_ReversedPrism A_ReversedPrism k where
joinKinds r = r
instance k ~ A_ReversedPrism => JoinKinds A_ReversedPrism An_Iso k where
joinKinds r = r
-- no JoinKinds A_ReversedPrism A_ReversedLens
instance k ~ An_AffineFold => JoinKinds A_ReversedPrism A_Prism k where
joinKinds r = r
-- no JoinKinds A_ReversedPrism A_Review
instance k ~ A_Getter => JoinKinds A_ReversedPrism A_Lens k where
joinKinds r = r
instance k ~ A_Getter => JoinKinds A_ReversedPrism A_Getter k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_ReversedPrism An_AffineTraversal k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_ReversedPrism An_AffineFold k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_ReversedPrism A_Traversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_ReversedPrism A_Fold k where
joinKinds r = r
-- no JoinKinds A_ReversedPrism A_Setter
-- A_Prism -----
instance k ~ A_Prism => JoinKinds A_Prism A_Prism k where
joinKinds r = r
instance k ~ A_Prism => JoinKinds A_Prism An_Iso k where
joinKinds r = r
instance k ~ A_Review => JoinKinds A_Prism A_ReversedLens k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_Prism A_ReversedPrism k where
joinKinds r = r
instance k ~ A_Review => JoinKinds A_Prism A_Review k where
joinKinds r = r
instance k ~ An_AffineTraversal => JoinKinds A_Prism A_Lens k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_Prism A_Getter k where
joinKinds r = r
instance k ~ An_AffineTraversal => JoinKinds A_Prism An_AffineTraversal k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_Prism An_AffineFold k where
joinKinds r = r
instance k ~ A_Traversal => JoinKinds A_Prism A_Traversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Prism A_Fold k where
joinKinds r = r
instance k ~ A_Setter => JoinKinds A_Prism A_Setter k where
joinKinds r = r
-- A_Review -----
instance k ~ A_Review => JoinKinds A_Review A_Review k where
joinKinds r = r
instance k ~ A_Review => JoinKinds A_Review An_Iso k where
joinKinds r = r
instance k ~ A_Review => JoinKinds A_Review A_ReversedLens k where
joinKinds r = r
-- no JoinKinds A_Review A_ReversedPrism
instance k ~ A_Review => JoinKinds A_Review A_Prism k where
joinKinds r = r
-- no JoinKinds A_Review A_Lens
-- no JoinKinds A_Review A_Getter
-- no JoinKinds A_Review An_AffineTraversal
-- no JoinKinds A_Review An_AffineFold
-- no JoinKinds A_Review A_Traversal
-- no JoinKinds A_Review A_Fold
-- no JoinKinds A_Review A_Setter
-- A_Lens -----
instance k ~ A_Lens => JoinKinds A_Lens A_Lens k where
joinKinds r = r
instance k ~ A_Lens => JoinKinds A_Lens An_Iso k where
joinKinds r = r
-- no JoinKinds A_Lens A_ReversedLens
instance k ~ A_Getter => JoinKinds A_Lens A_ReversedPrism k where
joinKinds r = r
instance k ~ An_AffineTraversal => JoinKinds A_Lens A_Prism k where
joinKinds r = r
-- no JoinKinds A_Lens A_Review
instance k ~ A_Getter => JoinKinds A_Lens A_Getter k where
joinKinds r = r
instance k ~ An_AffineTraversal => JoinKinds A_Lens An_AffineTraversal k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_Lens An_AffineFold k where
joinKinds r = r
instance k ~ A_Traversal => JoinKinds A_Lens A_Traversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Lens A_Fold k where
joinKinds r = r
instance k ~ A_Setter => JoinKinds A_Lens A_Setter k where
joinKinds r = r
-- A_Getter -----
instance k ~ A_Getter => JoinKinds A_Getter A_Getter k where
joinKinds r = r
instance k ~ A_Getter => JoinKinds A_Getter An_Iso k where
joinKinds r = r
-- no JoinKinds A_Getter A_ReversedLens
instance k ~ A_Getter => JoinKinds A_Getter A_ReversedPrism k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_Getter A_Prism k where
joinKinds r = r
-- no JoinKinds A_Getter A_Review
instance k ~ A_Getter => JoinKinds A_Getter A_Lens k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_Getter An_AffineTraversal k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds A_Getter An_AffineFold k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Getter A_Traversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Getter A_Fold k where
joinKinds r = r
-- no JoinKinds A_Getter A_Setter
-- An_AffineTraversal -----
instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal An_AffineTraversal k where
joinKinds r = r
instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal An_Iso k where
joinKinds r = r
-- no JoinKinds An_AffineTraversal A_ReversedLens
instance k ~ An_AffineFold => JoinKinds An_AffineTraversal A_ReversedPrism k where
joinKinds r = r
instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal A_Prism k where
joinKinds r = r
-- no JoinKinds An_AffineTraversal A_Review
instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal A_Lens k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds An_AffineTraversal A_Getter k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds An_AffineTraversal An_AffineFold k where
joinKinds r = r
instance k ~ A_Traversal => JoinKinds An_AffineTraversal A_Traversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds An_AffineTraversal A_Fold k where
joinKinds r = r
instance k ~ A_Setter => JoinKinds An_AffineTraversal A_Setter k where
joinKinds r = r
-- An_AffineFold -----
instance k ~ An_AffineFold => JoinKinds An_AffineFold An_AffineFold k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds An_AffineFold An_Iso k where
joinKinds r = r
-- no JoinKinds An_AffineFold A_ReversedLens
instance k ~ An_AffineFold => JoinKinds An_AffineFold A_ReversedPrism k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Prism k where
joinKinds r = r
-- no JoinKinds An_AffineFold A_Review
instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Lens k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Getter k where
joinKinds r = r
instance k ~ An_AffineFold => JoinKinds An_AffineFold An_AffineTraversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds An_AffineFold A_Traversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds An_AffineFold A_Fold k where
joinKinds r = r
-- no JoinKinds An_AffineFold A_Setter
-- A_Traversal -----
instance k ~ A_Traversal => JoinKinds A_Traversal A_Traversal k where
joinKinds r = r
instance k ~ A_Traversal => JoinKinds A_Traversal An_Iso k where
joinKinds r = r
-- no JoinKinds A_Traversal A_ReversedLens
instance k ~ A_Fold => JoinKinds A_Traversal A_ReversedPrism k where
joinKinds r = r
instance k ~ A_Traversal => JoinKinds A_Traversal A_Prism k where
joinKinds r = r
-- no JoinKinds A_Traversal A_Review
instance k ~ A_Traversal => JoinKinds A_Traversal A_Lens k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Traversal A_Getter k where
joinKinds r = r
instance k ~ A_Traversal => JoinKinds A_Traversal An_AffineTraversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Traversal An_AffineFold k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Traversal A_Fold k where
joinKinds r = r
instance k ~ A_Setter => JoinKinds A_Traversal A_Setter k where
joinKinds r = r
-- A_Fold -----
instance k ~ A_Fold => JoinKinds A_Fold A_Fold k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Fold An_Iso k where
joinKinds r = r
-- no JoinKinds A_Fold A_ReversedLens
instance k ~ A_Fold => JoinKinds A_Fold A_ReversedPrism k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Fold A_Prism k where
joinKinds r = r
-- no JoinKinds A_Fold A_Review
instance k ~ A_Fold => JoinKinds A_Fold A_Lens k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Fold A_Getter k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Fold An_AffineTraversal k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Fold An_AffineFold k where
joinKinds r = r
instance k ~ A_Fold => JoinKinds A_Fold A_Traversal k where
joinKinds r = r
-- no JoinKinds A_Fold A_Setter
-- A_Setter -----
instance k ~ A_Setter => JoinKinds A_Setter A_Setter k where
joinKinds r = r
instance k ~ A_Setter => JoinKinds A_Setter An_Iso k where
joinKinds r = r
-- no JoinKinds A_Setter A_ReversedLens
-- no JoinKinds A_Setter A_ReversedPrism
instance k ~ A_Setter => JoinKinds A_Setter A_Prism k where
joinKinds r = r
-- no JoinKinds A_Setter A_Review
instance k ~ A_Setter => JoinKinds A_Setter A_Lens k where
joinKinds r = r
-- no JoinKinds A_Setter A_Getter
instance k ~ A_Setter => JoinKinds A_Setter An_AffineTraversal k where
joinKinds r = r
-- no JoinKinds A_Setter An_AffineFold
instance k ~ A_Setter => JoinKinds A_Setter A_Traversal k where
joinKinds r = r
-- no JoinKinds A_Setter A_Fold
-- END GENERATED CONTENT
instance {-# OVERLAPPABLE #-}
( JoinKinds k l m
, TypeError (ShowType k :<>: Text " cannot be composed with " :<>: ShowType l)
) => JoinKinds k l m where
joinKinds _ = error "unreachable"