Merge pull request #16 from well-typed/hide-constraints

Hide Constraints type family

optics-core/optics-core.cabal

@@ -29,7 +29,6 @@ library
     Optics.Setter
     Optics.Traversal
   other-modules:
-    Optics.Internal
     Optics.Internal.Equality
     Optics.Internal.Fold
     Optics.Internal.Getter
@@ -43,3 +42,10 @@ library
     Optics.Internal.Subtyping
     Optics.Internal.Tagged
     Optics.Internal.Traversal
+
+test-suite optics-tests
+  default-language: Haskell2010
+  type: exitcode-stdio-1.0
+  main-is: Optics/Tests.hs
+  hs-source-dirs: tests
+  build-depends: base, optics-core

optics-core/src/Data/Tuple/Optics.hs

@@ -17,15 +17,15 @@ import Optics.Lens
 -- TODO: Introduce a 'Field1' class?
 --
 _1 :: Lens (a, b) (c, b) a c
-_1 = mkLens (\ wrap (a, b) -> (\ c -> (c, b)) <$> wrap a)
+_1 = vlLens (\ wrap (a, b) -> (\ c -> (c, b)) <$> wrap a)
 {-# INLINE _1 #-}
 
 -- | Lens for the second component of a pair.
 --
 -- TODO: Introduce a 'Field2' class?
 --
 _2 :: Lens (a, b) (a, c) b c
-_2 = mkLens (\ wrap (a, b) -> (\ c -> (a, c)) <$> wrap b)
+_2 = vlLens (\ wrap (a, b) -> (\ c -> (a, c)) <$> wrap b)
 {-# INLINE _2 #-}
 
 -- | Iso between the curried and uncurried versions of a function.

optics-core/src/Optics/Equality.hs

@@ -3,7 +3,7 @@ module Optics.Equality
   , Equality
   , Equality'
   , toEquality
-  , mkEquality
+  , vlEquality
   , Identical(..)
   , runEq
   , module Optics.Optic

optics-core/src/Optics/Fold.hs

@@ -3,7 +3,7 @@ module Optics.Fold
   ( A_Fold
   , Fold
   , toFold
-  , mkFold
+  , vlFold
   , foldMapOf
   , foldrOf
   , foldlOf'

optics-core/src/Optics/Getter.hs

@@ -2,7 +2,7 @@ module Optics.Getter
   ( A_Getter
   , Getter
   , toGetter
-  , mkGetter
+  , vlGetter
   , to
   , view
   , module Optics.Optic

optics-core/src/Optics/Internal/Equality.hs

@@ -23,10 +23,10 @@ toEquality :: Is k An_Equality => Optic k s t a b -> Equality s t a b
 toEquality = sub
 {-# INLINE toEquality #-}
 
--- | Create an equality.
-mkEquality :: Optic_ An_Equality s t a b -> Equality s t a b
-mkEquality = Optic
-{-# INLINE mkEquality #-}
+-- | Build an equality from the van Laarhoven representation.
+vlEquality :: (forall p f . p a (f b) -> p s (f t)) -> Equality s t a b
+vlEquality = Optic
+{-# INLINE vlEquality #-}
 
 -- | Proof of reflexivity.
 simple :: Equality' a a

optics-core/src/Optics/Internal/Fold.hs

@@ -24,10 +24,10 @@ toFold :: Is k A_Fold => Optic' k s a -> Fold s a
 toFold = sub
 {-# INLINE toFold #-}
 
--- | Create a fold.
-mkFold :: Optic_' A_Fold s a -> Fold s a
-mkFold = Optic
-{-# INLINE mkFold #-}
+-- | Build a fold from the van Laarhoven representation.
+vlFold :: (forall f . (Applicative f, Contravariant f) => (a -> f a) -> s -> f s) -> Fold s a
+vlFold = Optic
+{-# INLINE vlFold #-}
 
 -- | Fold via embedding into a monoid.
 foldMapOf :: (Monoid r, Is k A_Fold) => Optic' k s a -> (a -> r) -> s -> r

optics-core/src/Optics/Internal/Getter.hs

@@ -22,10 +22,10 @@ toGetter :: Is k A_Getter => Optic' k s a -> Getter s a
 toGetter = sub
 {-# INLINE toGetter #-}
 
--- | Create a getter.
-mkGetter :: Optic_' A_Getter s a -> Getter s a
-mkGetter = Optic
-{-# INLINE mkGetter #-}
+-- | Build a getter from the van Laarhoven representation.
+vlGetter :: (forall f . (Contravariant f, Functor f) => (a -> f a) -> s -> f s) -> Getter s a
+vlGetter = Optic
+{-# INLINE vlGetter #-}
 
 -- | Build a getter from a function.
 to :: (s -> a) -> Getter s a

optics-core/src/Optics/Internal/Iso.hs

@@ -25,10 +25,10 @@ toIso :: Is k An_Iso => Optic k s t a b -> Iso s t a b
 toIso = sub
 {-# INLINE toIso #-}
 
--- | Create a lens.
-mkIso :: Optic_ An_Iso s t a b -> Iso s t a b
-mkIso = Optic
-{-# INLINE mkIso #-}
+-- | Build an iso from the van Laarhoven representation.
+vlIso :: (forall p f . (Profunctor p, Functor f) => p a (f b) -> p s (f t)) -> Iso s t a b
+vlIso = Optic
+{-# INLINE vlIso #-}
 
 -- | Build an iso from a pair of inverse functions.
 iso :: (s -> a) -> (b -> t) -> Iso s t a b

optics-core/src/Optics/Internal/Lens.hs

@@ -22,12 +22,12 @@ toLens :: Is k A_Lens => Optic k s t a b -> Lens s t a b
 toLens = sub
 {-# INLINE toLens #-}
 
--- | Create a lens.
-mkLens :: Optic_ A_Lens s t a b -> Lens s t a b
-mkLens = Optic
-{-# INLINE mkLens #-}
+-- | Build a lens from the van Laarhoven representation.
+vlLens :: (forall f . Functor f => (a -> f b) -> s -> f t) -> Lens s t a b
+vlLens = Optic
+{-# INLINE vlLens #-}
 
 -- | Build a lens from a getter and setter.
 lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
-lens get set = mkLens (\ f s -> set s <$> f (get s))
+lens get set = vlLens (\ f s -> set s <$> f (get s))
 {-# INLINE lens #-}

optics-core/src/Optics/Internal/Prism.hs

@@ -23,15 +23,15 @@ toPrism :: Is k A_Prism => Optic k s t a b -> Prism s t a b
 toPrism = sub
 {-# INLINE toPrism #-}
 
--- | Create a prism.
-mkPrism :: Optic_ A_Prism s t a b -> Prism s t a b
-mkPrism = Optic
-{-# INLINE mkPrism #-}
+-- | Build a prism from the van Laarhoven representation.
+vlPrism :: (forall p f . (Choice p, Applicative f) => p a (f b) -> p s (f t)) -> Prism s t a b
+vlPrism = Optic
+{-# INLINE vlPrism #-}
 
 -- | Build a prism from a constructor and a matcher.
 prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
 prism construct match =
-  mkPrism (\ p -> dimap match (either pure (fmap construct)) (right' p))
+  vlPrism (\ p -> dimap match (either pure (fmap construct)) (right' p))
 {-# INLINE prism #-}
 
 -- withPrism

optics-core/src/Optics/Internal/Review.hs

@@ -27,8 +27,8 @@ toReview :: Is k A_Review => Optic k s t a b -> Review s t a b
 toReview = sub
 {-# INLINE toReview #-}
 
--- | Create a review.
-mkReview :: Optic_ A_Review s t a b -> Review s t a b
-mkReview = Optic
-{-# INLINE mkReview #-}
+-- | Build a review from the van Laarhoven representation.
+vlReview :: (forall p . (Choice p, Bifunctor p) => p a (Identity b) -> p s (Identity t)) -> Review s t a b
+vlReview = Optic
+{-# INLINE vlReview #-}
 

optics-core/src/Optics/Internal/Setter.hs

@@ -25,16 +25,20 @@ toSetter :: Is k A_Setter => Optic k s t a b -> Setter s t a b
 toSetter = sub
 {-# INLINE toSetter #-}
 
--- | Create a setter.
-mkSetter :: Optic_ A_Setter s t a b -> Setter s t a b
-mkSetter = Optic
-{-# INLINE mkSetter #-}
+-- | Build a setter from the van Laarhoven representation.
+vlSetter :: ((a -> Identity b) -> s -> Identity t) -> Setter s t a b
+vlSetter x = Optic x
+{-# INLINE vlSetter #-}
 
--- | Build a setter.
+-- | Build a setter from a function to modify the element(s).
 sets :: ((a -> b) -> (s -> t)) -> Setter s t a b
 sets f = Optic (coerce f)
 {-# INLINE sets #-}
 
+-- | Build a setter from a functor.
+mapped :: Functor f => Setter (f a) (f b) a b
+mapped = sets fmap
+
 -- | Apply a setter as a modifier.
 over :: Is k A_Setter => Optic k s t a b -> (a -> b) -> s -> t
 over o = coerce (getOptic (toSetter o))

optics-core/src/Optics/Internal/Subtyping.hs

@@ -1,4 +1,7 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Instances to implement the subtyping hierarchy between optics.
@@ -187,3 +190,32 @@ instance Join An_Equality A_Review     A_Review
 instance Join An_Equality A_Prism      A_Prism
 instance Join An_Equality An_Iso       An_Iso
 
+
+
+-- | A constraint that can never be satisfied (accompanied by a
+-- helpful witness to anything you like).
+class Absurd where
+  absurd :: a
+
+-- | In order to get nice error messages, we complete the type lattice
+-- with a universal supertype, whose constraints can never be
+-- satisfied.
+data Bogus
+type instance Constraints Bogus p f = Absurd
+instance Is k Bogus where
+  implies = absurd
+
+-- | This typeclass has no instances, and is used so that we get
+-- suitable unsolved constraint errors when attempting to compose
+-- flavours that do not have a (non-'Bogus') common supertype.
+--
+-- For example, if you try to compose a fold with a setter then you
+-- will get an error
+--
+-- > Could not deduce (CanCompose A_Fold A_Setter)
+class Absurd => CanCompose k l
+
+instance CanCompose A_Fold   A_Setter => Join A_Fold   A_Setter Bogus
+instance CanCompose A_Setter A_Fold   => Join A_Setter A_Fold   Bogus
+instance CanCompose A_Setter A_Getter => Join A_Setter A_Getter Bogus
+instance CanCompose A_Getter A_Setter => Join A_Getter A_Setter Bogus

optics-core/src/Optics/Internal/Traversal.hs

@@ -23,16 +23,21 @@ toTraversal :: Is k A_Traversal => Optic k s t a b -> Traversal s t a b
 toTraversal = sub
 {-# INLINE toTraversal #-}
 
--- | Create a traversal.
-mkTraversal :: Optic_ A_Traversal s t a b -> Traversal s t a b
-mkTraversal = Optic
-{-# INLINE mkTraversal #-}
+-- | Build a traversal from the van Laarhoven representation.
+vlTraversal :: (forall f . Applicative f => (a -> f b) -> s -> f t) -> Traversal s t a b
+vlTraversal = Optic
+{-# INLINE vlTraversal #-}
 
 -- | Traversal via the 'Traversal' class.
 --
 -- TODO: This function is not necessary in 'lens', one can simply
 -- use 'traverse'. The name here is preliminary.
 --
 _traverse :: Traversable t => Traversal (t a) (t b) a b
-_traverse = mkTraversal traverse
+_traverse = vlTraversal traverse
 {-# INLINE _traverse #-}
+
+-- | Convert a traversal to the van Laarhoven representation.
+traversalOf :: forall k s t a b . Is k A_Traversal => Optic k s t a b
+            -> (forall f . Applicative f => (a -> f b) -> s -> f t)
+traversalOf = getOptic . toTraversal

optics-core/src/Optics/Iso.hs

@@ -3,7 +3,7 @@ module Optics.Iso
   , Iso
   , Iso'
   , toIso
-  , mkIso
+  , vlIso
   , iso
   , withIso
   , from

optics-core/src/Optics/Lens.hs

@@ -3,7 +3,7 @@ module Optics.Lens
   , Lens
   , Lens'
   , toLens
-  , mkLens
+  , vlLens
   , lens
   , module Optics.Optic
   )