{-# 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. -- -- 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 JoinKinds An_Iso An_Iso An_Iso where joinKinds r = r instance JoinKinds An_Iso A_ReversedLens A_ReversedLens where joinKinds r = r instance JoinKinds An_Iso A_ReversedPrism A_ReversedPrism where joinKinds r = r instance JoinKinds An_Iso A_Prism A_Prism where joinKinds r = r instance JoinKinds An_Iso A_Review A_Review where joinKinds r = r instance JoinKinds An_Iso A_Lens A_Lens where joinKinds r = r instance JoinKinds An_Iso A_Getter A_Getter where joinKinds r = r instance JoinKinds An_Iso An_AffineTraversal An_AffineTraversal where joinKinds r = r instance JoinKinds An_Iso An_AffineFold An_AffineFold where joinKinds r = r instance JoinKinds An_Iso A_Traversal A_Traversal where joinKinds r = r instance JoinKinds An_Iso A_Fold A_Fold where joinKinds r = r instance JoinKinds An_Iso A_Setter A_Setter where joinKinds r = r -- A_ReversedLens ----- instance JoinKinds A_ReversedLens A_ReversedLens A_ReversedLens where joinKinds r = r instance JoinKinds A_ReversedLens An_Iso A_ReversedLens where joinKinds r = r -- no JoinKinds A_ReversedLens A_ReversedPrism instance JoinKinds A_ReversedLens A_Prism A_Review where joinKinds r = r instance JoinKinds A_ReversedLens A_Review A_Review 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 JoinKinds A_ReversedPrism A_ReversedPrism A_ReversedPrism where joinKinds r = r instance JoinKinds A_ReversedPrism An_Iso A_ReversedPrism where joinKinds r = r -- no JoinKinds A_ReversedPrism A_ReversedLens instance JoinKinds A_ReversedPrism A_Prism An_AffineFold where joinKinds r = r -- no JoinKinds A_ReversedPrism A_Review instance JoinKinds A_ReversedPrism A_Lens A_Getter where joinKinds r = r instance JoinKinds A_ReversedPrism A_Getter A_Getter where joinKinds r = r instance JoinKinds A_ReversedPrism An_AffineTraversal An_AffineFold where joinKinds r = r instance JoinKinds A_ReversedPrism An_AffineFold An_AffineFold where joinKinds r = r instance JoinKinds A_ReversedPrism A_Traversal A_Fold where joinKinds r = r instance JoinKinds A_ReversedPrism A_Fold A_Fold where joinKinds r = r -- no JoinKinds A_ReversedPrism A_Setter -- A_Prism ----- instance JoinKinds A_Prism A_Prism A_Prism where joinKinds r = r instance JoinKinds A_Prism An_Iso A_Prism where joinKinds r = r instance JoinKinds A_Prism A_ReversedLens A_Review where joinKinds r = r instance JoinKinds A_Prism A_ReversedPrism An_AffineFold where joinKinds r = r instance JoinKinds A_Prism A_Review A_Review where joinKinds r = r instance JoinKinds A_Prism A_Lens An_AffineTraversal where joinKinds r = r instance JoinKinds A_Prism A_Getter An_AffineFold where joinKinds r = r instance JoinKinds A_Prism An_AffineTraversal An_AffineTraversal where joinKinds r = r instance JoinKinds A_Prism An_AffineFold An_AffineFold where joinKinds r = r instance JoinKinds A_Prism A_Traversal A_Traversal where joinKinds r = r instance JoinKinds A_Prism A_Fold A_Fold where joinKinds r = r instance JoinKinds A_Prism A_Setter A_Setter where joinKinds r = r -- A_Review ----- instance JoinKinds A_Review A_Review A_Review where joinKinds r = r instance JoinKinds A_Review An_Iso A_Review where joinKinds r = r instance JoinKinds A_Review A_ReversedLens A_Review where joinKinds r = r -- no JoinKinds A_Review A_ReversedPrism instance JoinKinds A_Review A_Prism A_Review 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 JoinKinds A_Lens A_Lens A_Lens where joinKinds r = r instance JoinKinds A_Lens An_Iso A_Lens where joinKinds r = r -- no JoinKinds A_Lens A_ReversedLens instance JoinKinds A_Lens A_ReversedPrism A_Getter where joinKinds r = r instance JoinKinds A_Lens A_Prism An_AffineTraversal where joinKinds r = r -- no JoinKinds A_Lens A_Review instance JoinKinds A_Lens A_Getter A_Getter where joinKinds r = r instance JoinKinds A_Lens An_AffineTraversal An_AffineTraversal where joinKinds r = r instance JoinKinds A_Lens An_AffineFold An_AffineFold where joinKinds r = r instance JoinKinds A_Lens A_Traversal A_Traversal where joinKinds r = r instance JoinKinds A_Lens A_Fold A_Fold where joinKinds r = r instance JoinKinds A_Lens A_Setter A_Setter where joinKinds r = r -- A_Getter ----- instance JoinKinds A_Getter A_Getter A_Getter where joinKinds r = r instance JoinKinds A_Getter An_Iso A_Getter where joinKinds r = r -- no JoinKinds A_Getter A_ReversedLens instance JoinKinds A_Getter A_ReversedPrism A_Getter where joinKinds r = r instance JoinKinds A_Getter A_Prism An_AffineFold where joinKinds r = r -- no JoinKinds A_Getter A_Review instance JoinKinds A_Getter A_Lens A_Getter where joinKinds r = r instance JoinKinds A_Getter An_AffineTraversal An_AffineFold where joinKinds r = r instance JoinKinds A_Getter An_AffineFold An_AffineFold where joinKinds r = r instance JoinKinds A_Getter A_Traversal A_Fold where joinKinds r = r instance JoinKinds A_Getter A_Fold A_Fold where joinKinds r = r -- no JoinKinds A_Getter A_Setter -- An_AffineTraversal ----- instance JoinKinds An_AffineTraversal An_AffineTraversal An_AffineTraversal where joinKinds r = r instance JoinKinds An_AffineTraversal An_Iso An_AffineTraversal where joinKinds r = r -- no JoinKinds An_AffineTraversal A_ReversedLens instance JoinKinds An_AffineTraversal A_ReversedPrism An_AffineFold where joinKinds r = r instance JoinKinds An_AffineTraversal A_Prism An_AffineTraversal where joinKinds r = r -- no JoinKinds An_AffineTraversal A_Review instance JoinKinds An_AffineTraversal A_Lens An_AffineTraversal where joinKinds r = r instance JoinKinds An_AffineTraversal A_Getter An_AffineFold where joinKinds r = r instance JoinKinds An_AffineTraversal An_AffineFold An_AffineFold where joinKinds r = r instance JoinKinds An_AffineTraversal A_Traversal A_Traversal where joinKinds r = r instance JoinKinds An_AffineTraversal A_Fold A_Fold where joinKinds r = r instance JoinKinds An_AffineTraversal A_Setter A_Setter where joinKinds r = r -- An_AffineFold ----- instance JoinKinds An_AffineFold An_AffineFold An_AffineFold where joinKinds r = r instance JoinKinds An_AffineFold An_Iso An_AffineFold where joinKinds r = r -- no JoinKinds An_AffineFold A_ReversedLens instance JoinKinds An_AffineFold A_ReversedPrism An_AffineFold where joinKinds r = r instance JoinKinds An_AffineFold A_Prism An_AffineFold where joinKinds r = r -- no JoinKinds An_AffineFold A_Review instance JoinKinds An_AffineFold A_Lens An_AffineFold where joinKinds r = r instance JoinKinds An_AffineFold A_Getter An_AffineFold where joinKinds r = r instance JoinKinds An_AffineFold An_AffineTraversal An_AffineFold where joinKinds r = r instance JoinKinds An_AffineFold A_Traversal A_Fold where joinKinds r = r instance JoinKinds An_AffineFold A_Fold A_Fold where joinKinds r = r -- no JoinKinds An_AffineFold A_Setter -- A_Traversal ----- instance JoinKinds A_Traversal A_Traversal A_Traversal where joinKinds r = r instance JoinKinds A_Traversal An_Iso A_Traversal where joinKinds r = r -- no JoinKinds A_Traversal A_ReversedLens instance JoinKinds A_Traversal A_ReversedPrism A_Fold where joinKinds r = r instance JoinKinds A_Traversal A_Prism A_Traversal where joinKinds r = r -- no JoinKinds A_Traversal A_Review instance JoinKinds A_Traversal A_Lens A_Traversal where joinKinds r = r instance JoinKinds A_Traversal A_Getter A_Fold where joinKinds r = r instance JoinKinds A_Traversal An_AffineTraversal A_Traversal where joinKinds r = r instance JoinKinds A_Traversal An_AffineFold A_Fold where joinKinds r = r instance JoinKinds A_Traversal A_Fold A_Fold where joinKinds r = r instance JoinKinds A_Traversal A_Setter A_Setter where joinKinds r = r -- A_Fold ----- instance JoinKinds A_Fold A_Fold A_Fold where joinKinds r = r instance JoinKinds A_Fold An_Iso A_Fold where joinKinds r = r -- no JoinKinds A_Fold A_ReversedLens instance JoinKinds A_Fold A_ReversedPrism A_Fold where joinKinds r = r instance JoinKinds A_Fold A_Prism A_Fold where joinKinds r = r -- no JoinKinds A_Fold A_Review instance JoinKinds A_Fold A_Lens A_Fold where joinKinds r = r instance JoinKinds A_Fold A_Getter A_Fold where joinKinds r = r instance JoinKinds A_Fold An_AffineTraversal A_Fold where joinKinds r = r instance JoinKinds A_Fold An_AffineFold A_Fold where joinKinds r = r instance JoinKinds A_Fold A_Traversal A_Fold where joinKinds r = r -- no JoinKinds A_Fold A_Setter -- A_Setter ----- instance JoinKinds A_Setter A_Setter A_Setter where joinKinds r = r instance JoinKinds A_Setter An_Iso A_Setter where joinKinds r = r -- no JoinKinds A_Setter A_ReversedLens -- no JoinKinds A_Setter A_ReversedPrism instance JoinKinds A_Setter A_Prism A_Setter where joinKinds r = r -- no JoinKinds A_Setter A_Review instance JoinKinds A_Setter A_Lens A_Setter where joinKinds r = r -- no JoinKinds A_Setter A_Getter instance JoinKinds A_Setter An_AffineTraversal A_Setter where joinKinds r = r -- no JoinKinds A_Setter An_AffineFold instance JoinKinds A_Setter A_Traversal A_Setter 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"