@@ -1,11 +1,17 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeApplications #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -Wno-orphans #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# OPTIONS_GHC -Wno-orphans #-}
915
1016
1117--------------------------------------------------------------------------------
@@ -17,20 +23,115 @@
1723-- Stability : experimental
1824-- Portability : non-portable
1925--
20−-- Provides an (orphan) IsLabel instance for field lenses.
26+-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
2127-- Use at your own risk.
2228--------------------------------------------------------------------------------
2329
24−module Data.Generics.Labels () where
30+module Data.Generics.Labels (
31+ -- * Orphan IsLabel Instance
32+ -- $sec1
33+ Field(..)
34+ , Field'
35+ , Constructor(..)
36+ , Constructor'
37+ ) where
2538
2639import Data.Generics.Product
40+import Data.Generics.Sum
41+import Data.Generics.Internal.VL.Lens (Lens)
42+import Data.Generics.Internal.VL.Prism (Prism)
43+
44+import Data.Profunctor (Choice)
45+import Data.Type.Bool (type (&&))
46+import Data.Type.Equality (type (==))
47+
2748import GHC.OverloadedLabels
49+import GHC.TypeLits
50+
51+
52+-- $sec1
53+-- An instance for creating lenses and prisms with @#identifiers@ from the
54+-- @OverloadedLabels@ extension. Note that since overloaded labels do not
55+-- support symbols starting with capital letters, all prisms (which come from
56+-- constructor names, which are capitalized) must be prefixed with an underscore
57+-- (e.g. @#_ConstructorName@).
58+--
59+-- Morally:
60+--
61+-- @
62+-- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...
63+-- @
64+-- and
65+--
66+-- @
67+-- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...
68+-- @
69+--
70+-- Remember:
71+--
72+-- @
73+-- type Lens = forall f. Functor f => (a -> f b) -> s -> f t
74+--
75+-- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
76+-- @
77+--
78+-- The orphan instance is unavoidable if we want to work with
79+-- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).
2880
81+-- | 'Field' is morally the same as 'HasField', but it is constructed from an
82+-- incoherent combination of 'HasField' and 'HasField''. In this way, it can be
83+-- seamlessly used in the 'IsLabel' instance even when dealing with data types
84+-- that don't have 'Field' instances (like data instances).
85+class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where
86+ fieldLens :: Lens s t a b
2987
30−instance (HasField field s t a b, Functor f, sft ~ (s -> f t)) =>
31− IsLabel field ((a -> f b) -> sft) where
88+type Field' name s a = Field name s s a a
89+
90+instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where
91+ fieldLens = field @name
92+
93+instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where
94+ fieldLens = field' @name
95+
96+-- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an
97+-- incoherent combination of 'AsConstructor' and 'AsConstructor''. In this way, it can be
98+-- seamlessly used in the 'IsLabel' instance even when dealing with data types
99+-- that don't have 'Constructor' instances (like data instances).
100+class Constructor name s t a b | name s -> a, name t -> b where
101+ constructorPrism :: Prism s t a b
102+
103+type Constructor' name s a = Constructor name s s a a
104+
105+instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where
106+ constructorPrism = _Ctor @name
107+
108+instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where
109+ constructorPrism = _Ctor' @name
110+
111+
112+instance ( (CmpSymbol "_@" name == 'LT && CmpSymbol "_{" name == 'GT) ~ capital
113+ , IsLabelHelper capital name p f s t a b
114+ , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where
32115#if __GLASGOW_HASKELL__ >= 802
33− fromLabel = field @field
116+ fromLabel = labelOutput @capital @name @p @f
34117#else
35− fromLabel _ = field @field
118+ fromLabel _ = labelOutput @capital @name @p @f
36119#endif
120+
121+-- | This helper class allows us to customize the output type of the lens to be
122+-- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to
123+-- choose between whether we're dealing with a lens or a prism. The choice is
124+-- made by whether the @capital@ argument is true or false, which is determined by
125+-- whether the symbol starts with an underscore followed by a capital letter
126+-- (a check done in the 'IsLabel' instance above). If so, then we're dealing
127+-- with a constructor name, which should be a prism, and otherwise, it's a field
128+-- name, so we have a lens.
129+class IsLabelHelper capital name p f s t a b where
130+ labelOutput :: p a (f b) -> p s (f t)
131+
132+instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
133+ labelOutput = fieldLens @name
134+
135+instance ( Applicative f, Choice p, Constructor name s t a b
136+ , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where
137+ labelOutput = constructorPrism @name