packages feed

ten (empty) → 0.1.0.0

raw patch · 23 files changed

+2952/−0 lines, 23 filesdep +HUnitdep +adjunctionsdep +base

Dependencies added: HUnit, adjunctions, base, data-default-class, deepseq, distributive, hashable, portray, portray-diff, some, ten, test-framework, test-framework-hunit, text, transformers, wrapped

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++Initial version.
+ LICENSE view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ src/Data/Functor/Field.hs view
@@ -0,0 +1,225 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides 'Generic1' derivation of 'Representable' based on 'Field'.+--+-- This relies on the observation that a parametric function+-- @forall a. f a -> a@ is isomorphic to the set of "indices" of @f@, i.e.+-- @'Rep' f@.  With the appropriate instances, we can do anything with it that+-- we could with a hand-written ADT 'Rep' type.  So, this module provides a way+-- to use exactly that type as 'Rep', and the needed instances to make it+-- convenient to use.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Functor.Field+         ( Field(..)+         , FieldRep(..), FieldPaths(..), GFieldPaths(..), GTabulate(..)+         ) where++import Control.Monad.Trans.State (state, evalState)+import Data.Coerce (coerce)+import Data.Proxy (Proxy(..))+import qualified Data.Text as T+import GHC.Generics+         ( Generic1(..)+         , (:*:)(..), (:.:)(..)+         , M1(..), Rec1(..), U1(..), Par1(..)+         , Meta(..), S, C, D+         )+import GHC.TypeLits (KnownSymbol, symbolVal)++import Data.Distributive (Distributive(..))+import Data.Hashable (Hashable(..))+import Data.Functor.Rep (Representable(..), distributeRep, collectRep)+import Data.Portray (Portray(..), Portrayal(..))+import Data.Portray.Diff (Diff(..), diffVs)+import Data.Wrapped (Wrapped1(..))++import Data.Ten.Internal+         ( PathComponent(..), dropUnderscore, showsPath, starFst, starSnd+         , portrayPath+         )++-- | A 'Rep' type in the form of a parametric accessor function.+newtype Field f = Field { getField :: forall a. f a -> a }++fieldNumbers :: (Traversable f, Applicative f) => f Int+fieldNumbers = flip evalState 0 $ sequenceA $ pure $ state $ \i -> (i, i + 1)++instance (Traversable f, Applicative f) => Eq (Field f) where+  Field f == Field g = f fieldNumbers == g fieldNumbers++instance (Traversable f, Applicative f) => Ord (Field f) where+  Field f `compare` Field g = f fieldNumbers `compare` g fieldNumbers++instance (Traversable f, Applicative f) => Hashable (Field f) where+  hashWithSalt salt (Field f) = hashWithSalt salt $ f fieldNumbers++-- | Build a record where each field has a description of the field's location.+--+-- This primarily powers the 'Show' and 'Portray' instances of 'Field'.+class FieldPaths f where+  fieldPaths :: f [PathComponent]++instance FieldPaths f => Show (Field f) where+  showsPrec p (Field f) = showParen (p > 10) $+    showString "Field " . showsPath 11 (coerce $ f fieldPaths)++instance FieldPaths f => Portray (Field f) where+  portray (Field f) = Apply "Field" [portrayPath $ f fieldPaths]++instance (Traversable f, Applicative f, FieldPaths f) => Diff (Field f) where+  diff f g+    | f == g    = Nothing+    | otherwise = Just $ portray f `diffVs` portray g++instance (Generic1 rec, GFieldPaths (Rep1 rec))+      => FieldPaths (Wrapped1 Generic1 rec) where+  fieldPaths = Wrapped1 . to1 $ gfieldPaths id+  {-# INLINE fieldPaths #-}++-- | The 'Generic1' implementation of 'FieldPaths'.+--+-- As with 'GTabulate', derive this only to enable using your type as a+-- sub-record; otherwise just derive 'FieldPaths' directly.+class GFieldPaths rec where+  gfieldPaths :: ([PathComponent] -> r) -> rec r++instance GFieldPaths U1 where+  gfieldPaths _ = U1+  {-# INLINE gfieldPaths #-}++instance GFieldPaths Par1 where+  gfieldPaths r = Par1 $ r []+  {-# INLINE gfieldPaths #-}++instance GFieldPaths rec => GFieldPaths (Rec1 rec) where+  gfieldPaths = Rec1 . gfieldPaths+  {-# INLINE gfieldPaths #-}++instance GFieldPaths rec => GFieldPaths (M1 C i rec) where+  gfieldPaths = M1 . gfieldPaths+  {-# INLINE gfieldPaths #-}++-- Non-newtype constructors: wait until we get to the fields to assign a path+-- component.+instance GFieldPaths rec+      => GFieldPaths (M1 D ('MetaData n m p 'False) rec) where+  gfieldPaths = M1 . gfieldPaths+  {-# INLINE gfieldPaths #-}++-- Newtype constructors: immediately decide to use 'NewtypeIso'.+instance GFieldPaths rec+      => GFieldPaths+           (M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec))) where+  gfieldPaths r = M1 . M1 . M1 $ gfieldPaths (r . (NewtypeIso:))+  {-# INLINE gfieldPaths #-}++instance (KnownSymbol sym, GFieldPaths rec)+      => GFieldPaths (M1 S ('MetaSel ('Just sym) b c d) rec) where+  gfieldPaths r = M1 . gfieldPaths $+    r . (NamedField (T.pack nm) (T.pack $ dropUnderscore nm) :)+   where+    nm = symbolVal @sym Proxy+  {-# INLINE gfieldPaths #-}++instance (GFieldPaths f, GFieldPaths g) => GFieldPaths (f :*: g) where+  gfieldPaths r = gfieldPaths r :*: gfieldPaths r+  {-# INLINE gfieldPaths #-}++instance (GFieldPaths f, GFieldPaths g) => GFieldPaths (f :.: g) where+  gfieldPaths r = Comp1 $+    gfieldPaths $ \outer ->+    gfieldPaths $ \inner ->+    r $ outer ++ inner+  {-# INLINE gfieldPaths #-}++-- | The 'Generic1' implementation of 'tabulate' for 'Field'.+class GTabulate rec where+  gtabulate :: (Field rec -> r) -> rec r++-- | A newtype carrying instances for use with @DerivingVia@.+--+-- This provides 'Applicative', 'Monad', 'Representable', and+-- 'Data.Functor.Update.Update'.+newtype FieldRep f a = FieldRep (f a)+  deriving Functor++-- Only to satisfy the superclass constraint of Representable.+instance (Generic1 f, GTabulate (Rep1 f), Functor f)+      => Distributive (FieldRep f) where+  distribute = distributeRep+  collect = collectRep++instance (Generic1 f, GTabulate (Rep1 f), Functor f)+      => Applicative (FieldRep f) where+  pure x = tabulate (const x)+  f <*> x = tabulate (index f <*> index x)++instance (Generic1 f, GTabulate (Rep1 f), Functor f)+      => Monad (FieldRep f) where+  x >>= f = tabulate (index x >>= index . f)++instance (Generic1 f, GTabulate (Rep1 f), Functor f)+      => Representable (FieldRep f) where+  type Rep (FieldRep f) = Field f+  index (FieldRep f) (Field g) = g f+  tabulate f = FieldRep $ to1 $ gtabulate $ \i -> f $ Field $ getField i . from1++instance GTabulate U1 where+  gtabulate _ = U1+  {-# INLINE gtabulate #-}++instance GTabulate rec => GTabulate (Rec1 rec) where+  gtabulate r = Rec1 $ gtabulate (coerce r)+  {-# INLINE gtabulate #-}++instance GTabulate rec => GTabulate (M1 k i rec) where+  gtabulate r = M1 $ gtabulate (coerce r)+  {-# INLINE gtabulate #-}++instance GTabulate Par1 where+  gtabulate r = Par1 $ r (Field coerce)+  {-# INLINE gtabulate #-}++instance (GTabulate f, GTabulate g) => GTabulate (f :*: g) where+  gtabulate r = ftab :*: gtab+   where+    ftab = gtabulate $ \ (Field g) -> r $ Field $ g . starFst+    gtab = gtabulate $ \ (Field g) -> r $ Field $ g . starSnd+  {-# INLINE gtabulate #-}++instance (GTabulate f, GTabulate g) => GTabulate (f :.: g) where+  gtabulate r = Comp1 $+    gtabulate $ \ (Field g0) ->+    gtabulate $ \ (Field g1) ->+    r (Field $ g1 . g0 . unComp1)+  {-# INLINE gtabulate #-}++{-+instance KnownNat n => GTabulate (Vec n) where+  gtabulate r = tabulate $ \i -> r $ Field (Vec.! i)+  {-# INLINE gtabulate #-}+  -}
+ src/Data/Functor/Update.hs view
@@ -0,0 +1,104 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Extends 'Representable' with support for modifying elements.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Functor.Update (Update(..), updateRep, ixRep, GUpdate(..)) where++import Data.Coerce (coerce)+import Data.Functor ((<&>))+import GHC.Generics+         ( Generic1(..)+         , (:*:)(..), (:.:)(..)+         , M1(..), Rec1(..), U1(..), Par1(..)+         )++import Data.Functor.Rep (Representable(..))++import Data.Functor.Field (Field(..), GTabulate(..), FieldRep(..))+import Data.Ten.Internal (mapStarFst, mapStarSnd)++-- | Extends 'Representable' with support for modifying elements.+--+-- If @'Eq' ('Rep' f)@ is available, this is already possible by roundabout+-- means, but this class lets instances provide a more direct method that+-- doesn't require per-field equality tests.+class Representable f => Update f where+  overRep :: Rep f -> (a -> a) -> f a -> f a++-- | Update an @f a@ at a given index.+updateRep :: Update f => Rep f -> a -> f a -> f a+updateRep i = overRep i . const++-- | A 'Control.Lens.Lens' to the field identified by a given 'Rep'.+--+-- @+--     ixRep :: Update f => Rep f -> Lens' (f a) a+-- @+ixRep :: (Update f, Functor m) => Rep f -> (a -> m a) -> f a -> m (f a)+ixRep i f = \fa -> f (index fa i) <&> \ma -> updateRep i ma fa++instance (Generic1 f, GTabulate (Rep1 f), GUpdate (Rep1 f), Functor f)+      => Update (FieldRep f) where+  overRep =+    \i f (FieldRep fa) -> FieldRep $ runFS (getField i setters_) f fa+   where+    setters_ :: f (FieldSetter f)+    setters_ = setters++-- | The 'Generic1' implementation of 'Update'.+class GUpdate rec where+  gsetters :: ((forall a. (a -> a) -> rec a -> rec a) -> r) -> rec r++instance GUpdate U1 where+  gsetters _r = U1+  {-# INLINE gsetters #-}++instance GUpdate rec => GUpdate (Rec1 rec) where+  gsetters r = Rec1 $ gsetters (\s -> r $ \f -> Rec1 . s f . unRec1)+  {-# INLINE gsetters #-}++instance GUpdate rec => GUpdate (M1 k i rec) where+  gsetters r = M1 $ gsetters (\s -> r $ \f -> M1 . s f . unM1)+  {-# INLINE gsetters #-}++instance GUpdate Par1 where+  gsetters r = Par1 $ r $ \f -> Par1 . f . unPar1+  {-# INLINE gsetters #-}++instance (GUpdate f, GUpdate g) => GUpdate (f :*: g) where+  gsetters r = fs :*: gs+   where+    fs = gsetters $ \s -> r $ mapStarFst . s+    gs = gsetters $ \s -> r $ mapStarSnd . s+  {-# INLINE gsetters #-}++instance (GUpdate f, GUpdate g) => GUpdate (f :.: g) where+  gsetters r = Comp1 $+    gsetters $ \ s0 ->+    gsetters $ \ s1 ->+    r $ \f -> coerce (s0 (s1 f))+  {-# INLINE gsetters #-}++newtype FieldSetter f = FS { runFS :: forall a. (a -> a) -> f a -> f a }++setters :: (Generic1 f, GUpdate (Rep1 f)) => f (FieldSetter f)+setters = to1 $ gsetters (\overI -> FS $ \f -> to1 . overI f . from1)
+ src/Data/Ten.hs view
@@ -0,0 +1,144 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Typeclass hierarchy of functors from @k -> Type@ to @Type@.+--+-- The naming convention @Functor10@ comes from the fact that it's a functor+-- from the category of objects with one type parameter to the category of+-- objects with zero type parameters.  See+-- <http://hackage.haskell.org/package/hakaru-0.4.0/docs/src/Language.Hakaru.Syntax.IClasses.html>+-- for precedent for this naming convention.+--+-- In this, the argument morphisms are of the form @forall a. m a -> n a@, and+-- the result morphisms are of the form @f m -> f n@.+--+-- The main parts of this are:+--+-- * 'Functor10' and the other similarly-named typeclasses, which are+-- essentially just translations of 'Functor' et al. to kind+-- @(k -> Type) -> Type@.+-- These are essentially 'Functor's with additional \"tag\" types+-- available at each occurrence of the argument.  Applying them to+-- @Identity@, you get essentially normal records, but other type parameters+-- give other interesting objects.+--+-- * (':**') and 'Exists' (two stock 'Functor10' types) plus appropriate+-- instances for products, sums, and compositions of functors as provided by+-- "GHC.Generics": (':*:'), (':+:'), and (':.:').+--+-- * 'Entails', which uses a GADT-like value to retrieve instances for its type+-- parameter.  This adds a lot of power to the otherwise-pretty-weak+-- 'Functor10' class hierarchy, since without access to corresponding+-- instances, all the input morphisms are unable to do anything whatsoever with+-- the \"tag\" types.  With 'Entails', though, one can use the fact that every+-- occurrence of @m a@ in @f m@ satisfies @c a@ to make instances of @c@+-- available while mapping/folding/traversing/etc. an @f m@.+--+-- The provided GHC.Generics-based deriving functionality is meant to be used+-- with the DerivingVia extension.  To get the full suite of classes on a+-- generic-record type, make sure every field is either an 'Ap10', another+-- nested generic-record, or an instance of 'Data.Functor.Update' applied to+-- one of the above.  Then, just add the deriving clauses:+--+-- @+--     data MyType f = MyType { _mrInt :: Ap10 Int f, _mrBool :: Ap10 Bool f }+--       deriving Generic1+--       deriving+--         ( Functor10, Foldable10, Traversable10+--         , Applicative10, Representable10, Update10, Constrained10 c+--         ) via Wrapped1 Generic1 MyType+--       deriving+--         ( Functor10WithIndex, Foldable10WithIndex, Traversable10WithIndex+--         ) via Wrapped1 Representable10 MyType+--+--     type instance Index10 MyType = Rep10 MyType+-- @++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten+  ( -- * Typeclasses+    -- ** Functor10+    module Data.Ten.Functor+  , module Data.Ten.Functor.WithIndex+    -- ** Foldable10+  , module Data.Ten.Foldable+  , module Data.Ten.Foldable.WithIndex+    -- ** Traversable10+  , module Data.Ten.Traversable+  , module Data.Ten.Traversable.WithIndex+    -- ** Applicative10+  , module Data.Ten.Applicative+    -- ** Representable10+  , module Data.Ten.Representable+    -- ** Update10+  , module Data.Ten.Update+    -- ** Entails+  , module Data.Ten.Entails++    -- * Standard 'Functor10's+  , module Data.Ten.Ap+  , module Data.Ten.Exists+  , module Data.Ten.Field+  , module Data.Ten.Sigma+  , (:.:)(..), (:*:)(..), (:+:)(..)+  ) where++import GHC.Generics ((:.:)(..), (:*:)(..), (:+:)(..))++import Data.Ten.Ap+import Data.Ten.Applicative+import Data.Ten.Entails+import Data.Ten.Exists+import Data.Ten.Field+import Data.Ten.Foldable+import Data.Ten.Foldable.WithIndex+import Data.Ten.Sigma+import Data.Ten.Functor+import Data.Ten.Functor.WithIndex+import Data.Ten.Representable+import Data.Ten.Traversable+import Data.Ten.Traversable.WithIndex+import Data.Ten.Update++-- TODO(awpr):+--+-- class Antimonoidal10 f where -- (Alternative10)+--   nah10 :: f (Const Void)+--   alt10 :: f m -> f m -> f (Sum m n)+--+-- class Contravariant10 f where+--   contramap10 :: (forall a. n a -> m a) -> f m -> f n
+ src/Data/Ten/Ap.hs view
@@ -0,0 +1,211 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides a field wrapper type to make @Generic1@ work with @Functor10@ etc.+--+-- GHC can't derive 'GHC.Generics.Generic1' instances for types that apply+-- their type parameter to a constant type (e.g. @data Thing f = Thing (f+-- Int)@, but it can handle the equivalent type when the application is hidden+-- under a newtype: @data Thing f = Thing (Ap10 Int f)@.  So, by wrapping each+-- field in this newtype and providing the appropriate instances, we can use+-- Generics to derive instances for the whole hierarchy of+-- 'Data.Ten.Functor.Functor10' and related classes.++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Ap+         ( -- * Field Wrapper+           Ap10(..)+           -- * Instances+           -- $ap10_instances+         ) where++import Data.Kind (Constraint, Type)+import GHC.Generics (Generic)++import Control.DeepSeq (NFData)+import Data.Default.Class (Default(..))+import Data.Hashable (Hashable(..))+import Data.Portray (Portray(..))+import Data.Portray.Diff (Diff)+import Data.Wrapped (Wrapped(..))++-- | A 'Data.Ten.Functor.Functor10' made by applying the argument to some type.+newtype Ap10 (a :: k) (f :: k -> Type) = Ap10 { unAp10 :: f a }+  deriving Generic++-- $ap10_instances+--+-- [Note: Ap10 instances]+--+-- Since @Ap10 a f@ is a newtype over @f a@, it can adopt any instance that+-- @f a@ has, e.g. @Eq (f a) => Eq (Ap10 a f)@.  This doesn't play very nicely+-- with inference of derived instance contexts, though: if you say @deriving+-- Eq@ on a type with an @f@ type parameter with an @Ap10 T f@ field, GHC will+-- complain about the missing instance @Eq (f T)@ rather than adding it to the+-- context.  However, if we can arrange for this to be expressed as a+-- Haskell98-looking constraint of the form @C f@, GHC will be willing to add+-- that to the inferred context.+--+-- We can do this by adding a new class @EqAp f@ with the instance we really+-- want as a superclass, and using that as the context of 'Ap10'\'s @Eq@+-- instance.  Now when trying to solve @Eq (Ap10 T f)@, GHC will simplify to+-- @(EqAp f, EqCtx f T)@.  However, if we have just a catch-all instance for+-- @EqAp@, GHC will simplify it further to the instance context of that+-- instance, which would bring us back to a constraint GHC won't add to the+-- context, @forall a. Eq a => Eq (f a)@.  We have to prevent GHC from doing+-- that simplification, which we can achieve by overlapping it with some other+-- instance, so that GHC can't choose the catch-all instance without knowing+-- more about @f@.  To avoid weird behavior from the overlap, we make an+-- otherwise-unused type 'Decoy' to carry the instance.+--+-- Finally, because @Ap10@ is poly-kinded, if we used @Eq@ directly as the+-- context of that quantified constraint, we'd be saying that @Ap10@ can only+-- be @Eq@ when its hidden kind parameter is @Type@.  Instead, we generalize it+-- to an associated type family 'EqCtx'.  This might be e.g.+-- 'GHC.TypeNats.KnownNat' for 'GHC.TypeNats.Nat's, or simply nothing for+-- phantom type parameters.  I'm not yet sure how to approach the instances for+-- other kinds -- for instance, should we provide stock ones, or expect users+-- to write kind-level newtypes and provide their own instances?+--+-- This trickery is applied to all the instances of Ap10.  In particular this+-- means @deriving (Eq, Ord, Read, Show, Default, NFData)@ and+-- @deriving (Portray, Diff) via Wrapped Generic T@ will all work.++newtype Decoy a = Decoy ()+  deriving stock (Eq, Ord, Read, Show, Generic)+  deriving newtype (Default, NFData, Hashable)+  deriving (Diff, Portray) via Wrapped Generic (Decoy a)++-- See [Note: Ap10 instances]+class (forall a. PortrayCtx f a => Portray (f a))+   => PortrayAp (f :: k -> Type) where+  type PortrayCtx f :: k -> Constraint++instance (forall a. Portray a => Portray (f a)) => PortrayAp f where+  type PortrayCtx f = Portray++instance {-# OVERLAPS #-} PortrayAp (Decoy :: Type -> Type) where+  type PortrayCtx Decoy = Portray++deriving newtype instance (PortrayCtx f a, PortrayAp f) => Portray (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. DiffCtx f a => Diff (f a)) => DiffAp (f :: k -> Type) where+  type DiffCtx f :: k -> Constraint++instance (forall a. Diff a => Diff (f a)) => DiffAp f where+  type DiffCtx f = Diff++instance {-# OVERLAPS #-} DiffAp (Decoy :: Type -> Type) where+  type DiffCtx Decoy = Diff++deriving newtype instance (DiffCtx f a, DiffAp f) => Diff (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. EqCtx f a => Eq (f a)) => EqAp (f :: k -> Type) where+  type EqCtx f :: k -> Constraint++instance (forall a. Eq a => Eq (f a)) => EqAp f where+  type EqCtx f = Eq++instance {-# OVERLAPS #-} EqAp (Decoy :: Type -> Type) where+  type EqCtx Decoy = Eq++deriving newtype instance (EqCtx f a, EqAp f) => Eq (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. OrdCtx f a => Ord (f a)) => OrdAp (f :: k -> Type) where+  type OrdCtx f :: k -> Constraint++instance (forall a. Ord a => Ord (f a)) => OrdAp f where+  type OrdCtx f = Ord++instance {-# OVERLAPS #-} OrdAp (Decoy :: Type -> Type) where+  type OrdCtx Decoy = Ord++deriving newtype+  instance (OrdCtx f a, OrdAp f, EqCtx f a, EqAp f) => Ord (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. ReadCtx f a => Read (f a)) => ReadAp (f :: k -> Type) where+  type ReadCtx f :: k -> Constraint++instance (forall a. Read a => Read (f a)) => ReadAp f where+  type ReadCtx f = Read++instance {-# OVERLAPS #-} ReadAp (Decoy :: Type -> Type) where+  type ReadCtx Decoy = Read++deriving newtype instance (ReadCtx f a, ReadAp f) => Read (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. ShowCtx f a => Show (f a)) => ShowAp (f :: k -> Type) where+  type ShowCtx f :: k -> Constraint++instance (forall a. Show a => Show (f a)) => ShowAp f where+  type ShowCtx f = Show++instance {-# OVERLAPS #-} ShowAp (Decoy :: Type -> Type) where+  type ShowCtx Decoy = Show++deriving newtype instance (ShowCtx f a, ShowAp f) => Show (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. DefaultCtx f a => Default (f a)) => DefaultAp (f :: k -> Type) where+  type DefaultCtx f :: k -> Constraint++instance (forall a. Default a => Default (f a)) => DefaultAp f where+  type DefaultCtx f = Default++instance {-# OVERLAPS #-} DefaultAp (Decoy :: Type -> Type) where+  type DefaultCtx Decoy = Default++deriving newtype instance (DefaultCtx f a, DefaultAp f) => Default (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. NFDataCtx f a => NFData (f a)) => NFDataAp (f :: k -> Type) where+  type NFDataCtx f :: k -> Constraint++instance (forall a. NFData a => NFData (f a)) => NFDataAp f where+  type NFDataCtx f = NFData++instance {-# OVERLAPS #-} NFDataAp (Decoy :: Type -> Type) where+  type NFDataCtx Decoy = NFData++deriving newtype instance (NFDataCtx f a, NFDataAp f) => NFData (Ap10 a f)++-- See [Note: Ap10 instances]+class (forall a. HashableCtx f a => Hashable (f a)) => HashableAp (f :: k -> Type) where+  type HashableCtx f :: k -> Constraint++instance (forall a. Hashable a => Hashable (f a)) => HashableAp f where+  type HashableCtx f = Hashable++instance {-# OVERLAPS #-} HashableAp (Decoy :: Type -> Type) where+  type HashableCtx Decoy = Hashable++deriving newtype instance (HashableCtx f a, HashableAp f) => Hashable (Ap10 a f)
+ src/Data/Ten/Applicative.hs view
@@ -0,0 +1,148 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides an analog of 'Applicative' over arity-1 type constructors.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Applicative+         ( Applicative10(..), (<*!), (*>!)+         , liftA310+         , (:->:)(Arr10, runArr10)+         , pure10C, liftA210C, liftA310C+         ) where++import Control.Applicative (liftA2)+import Data.Proxy (Proxy(..))+import GHC.Generics+         ( Generic1(..)+         , (:.:)(..), (:*:)(..)+         , K1(..), M1(..), Rec1(..), U1(..)+         )++import Data.Wrapped (Wrapped1(..))++import Data.Ten.Ap (Ap10(..))+import Data.Ten.Entails (Entails)+import Data.Ten.Functor (Functor10, (<$>!))+import Data.Ten.Functor.WithIndex (Index10, Functor10WithIndex, fmap10C)++infixl 4 <*>!+-- | 'Applicative' over arity-1 type constructors.+--+-- See also 'Functor10' and 'Data.Ten.Foldable.Foldable10'.+class Functor10 f => Applicative10 f where+  {-# MINIMAL pure10, ((<*>!) | liftA210) #-}++  -- | Lift a parametric @m@ value into an @f m@.+  pure10 :: (forall a. m a) -> f m++  -- | ('<*>') for 'Applicative10': zip two @f@s with 'runArr10'.+  (<*>!) :: f (m :->: n) -> f m -> f n+  (<*>!) = liftA210 (\ (Arr10 f') x' -> f' x')++  -- | 'Control.Applicative.liftA2' for 'Applicative10': zip two @f@s with a+  -- parametric function.+  liftA210 :: (forall a. m a -> n a -> o a) -> f m -> f n -> f o+  liftA210 f x y = (Arr10 . f) <$>! x <*>! y++instance (Generic1 f, Applicative10 (Rep1 f))+      => Applicative10 (Wrapped1 Generic1 f) where+  pure10 x = Wrapped1 $ to1 $ pure10 x+  liftA210 f (Wrapped1 x) (Wrapped1 y) =+    Wrapped1 $ to1 $ liftA210 f (from1 x) (from1 y)++instance Applicative10 (Ap10 a) where+  pure10 x = Ap10 x+  liftA210 f (Ap10 x) (Ap10 y) = Ap10 $ f x y++instance Monoid a => Applicative10 (K1 i a) where+  pure10 _ = K1 mempty+  liftA210 _ (K1 x) (K1 y) = K1 (x <> y)++-- no instance Applicative10 V1: V1 is uninhabited++instance Applicative10 U1 where+  pure10 _ = U1+  liftA210 _ U1 U1 = U1++deriving instance Applicative10 f => Applicative10 (Rec1 f)+deriving instance Applicative10 f => Applicative10 (M1 i c f)++-- no instance (Applicative10 f, Applicative10 g) => Applicative10 (f :+: g)++instance (Applicative10 f, Applicative10 g) => Applicative10 (f :*: g) where+  pure10 x = pure10 x :*: pure10 x+  liftA210 f (xl :*: xr) (yl :*: yr) = liftA210 f xl yl :*: liftA210 f xr yr++instance (Applicative f, Applicative10 g) => Applicative10 (f :.: g) where+  pure10 x = Comp1 $ pure (pure10 x)+  liftA210 f (Comp1 x) (Comp1 y) = Comp1 $ liftA2 (liftA210 f) x y++-- | A function @m a -> n a@ wrapped in a newtype for use as a type parameter.+--+-- This is used to represent the partially-applied functions in the left side+-- of ('<*>!').+newtype (m :->: n) a = Arr10 { runArr10 :: m a -> n a }++-- | 'Control.Applicative.liftA3' for 'Applicative10'.+liftA310+  :: Applicative10 f+  => (forall a. m a -> n a -> o a -> p a) -> f m -> f n -> f o -> f p+liftA310 f xs ys zs =+  (\x -> Arr10 (Arr10 . f x)) <$>! xs <*>! ys <*>! zs++infixl 4 <*!+-- | ('<*') for 'Applicative10'.+(<*!) :: Applicative10 f => f m -> f n -> f m+(<*!) = liftA210 const++infixl 4 *>!+-- | ('*>') for 'Applicative10'.+(*>!) :: Applicative10 f => f m -> f n -> f n+(*>!) = liftA210 (const id)++-- | 'pure10' with access to an instance for every element.+pure10C+  :: forall c f m+   . (Entails (Index10 f) c, Applicative10 f, Functor10WithIndex f)+  => (forall a. c a => m a) -> f m+pure10C x = fmap10C @c (const x) (pure10 Proxy)++-- | 'liftA210' with access to an instance for every element.+liftA210C+  :: forall c f m n o+   . (Entails (Index10 f) c, Applicative10 f, Functor10WithIndex f)+  => (forall a. c a => m a -> n a -> o a)+  -> f m -> f n -> f o+liftA210C f x y = fmap10C @c (Arr10 . f) x <*>! y++-- | 'liftA310' with access to an instance for every element.+liftA310C+  :: forall c f m n o p+   . (Entails (Index10 f) c, Applicative10 f, Functor10WithIndex f)+  => (forall a. c a => m a -> n a -> o a -> p a)+  -> f m -> f n -> f o -> f p+liftA310C f x y z = liftA210C @c (fmap Arr10 . f) x y <*>! z
+ src/Data/Ten/Entails.hs view
@@ -0,0 +1,88 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- | A typeclass of GADT-like types whose existence implies an instance.++module Data.Ten.Entails+         ( Entails(..), Dict1(..), (:!:)+         , withEntailment, byEntailment+         ) where++import Data.Kind (Constraint)+import Data.Proxy (Proxy(..))+import Data.Type.Equality ((:~:)(..))+import Type.Reflection (TypeRep)++-- We could just use Dict from "constraints", but it'd be a dependency that we+-- don't really need to have.++-- | A dictionary for the given arity-1 constraint constructor ("a class").+data Dict1 (c :: k -> Constraint) a = c a => Dict1++-- | A typeclass of GADT-like types whose existence implies an instance.+--+-- For a trivial example, the existence of @Int :~: b@ implies @Show b@, since+-- we can discover that @b@ is @Int@ and use the @Show Int@ instance.+class Entails k c where+  entailment :: k a -> Dict1 c a++-- | Non-GADTy types don't entail anything except parametric instances.+instance (forall a. c a) => Entails TypeRep c where entailment _ = Dict1+instance (forall a. c a) => Entails Proxy c where entailment _ = Dict1++-- | Equality to a particular type entails any instance that type has.+instance c a => Entails ((:~:) a) c where entailment Refl = Dict1++-- | 'Dict1's entail their own type parameter.+instance Entails (Dict1 c) c where entailment = id++-- | A utility "typeclass newtype" that's convenient with 'Entails'.+--+-- If you want to use 'entailment' to get an instance of the form @c (d a)@,+-- use @entailment \@(c :!: d)@.  Really I wanted to use the name (@:.:@), but+-- it's taken, so I just replaced the period with something else that involves+-- a dot near the typographic base line.+class c (d a) => (c :!: d) a+instance c (d a) => (c :!: d) a++-- | Bring an instance into scope using an 'Entails' instance.+--+-- @+--     (\ (k :: Int :~: b) (x :: b) -> withEntailment @Show k (show x)) Refl 2+-- @+withEntailment :: forall c k a r. Entails k c => k a -> (c a => r) -> r+withEntailment k r = case entailment @_ @c k of Dict1 -> r++-- | @flip 'withEntailment'@.+--+-- This is useful for "consuming" an index off the front of a function type and+-- turning it into an instance, e.g. in the context of an+-- 'Data.Ten.Functor.WithIndex.imap10' call.+byEntailment :: forall c k a r. Entails k c => (c a => r) -> k a -> r+byEntailment r k = withEntailment @c k r
+ src/Data/Ten/Exists.hs view
@@ -0,0 +1,77 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | A 'Functor10' made by applying the argument to an existential type.++{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.Ten.Exists (Exists(..)) where++import Data.Kind (Type)+import Data.Type.Equality ((:~:)(..), TestEquality(..))++import Data.GADT.Compare (GEq(..), GCompare(..), GOrdering(..))+import Data.Hashable (Hashable(..))+import Data.Portray (Portray(..), Portrayal(..))+import Data.Portray.Diff (Diff(..), diffVs)++import Data.Ten.Functor (Functor10(..))+import Data.Ten.Foldable (Foldable10(..))+import Data.Ten.Traversable (Traversable10(..))++-- | A 'Functor10' made by applying the argument to an existential type.+data Exists (m :: k -> Type) where+  Exists :: forall a m. m a -> Exists m++deriving stock instance (forall a. Show (m a)) => Show (Exists m)++instance GEq m => Eq (Exists m) where+  Exists x == Exists y = case geq x y of+    Nothing -> False+    Just _ -> True++instance GCompare m => Ord (Exists m) where+  compare (Exists x) (Exists y) = case gcompare x y of+    GLT -> LT+    GEQ -> EQ+    GGT -> GT++instance (forall a. Hashable (m a)) => Hashable (Exists m) where+  hashWithSalt s (Exists ka) = hashWithSalt s ka++instance (forall a. Portray (m a)) => Portray (Exists m) where+  portray (Exists x) = Apply (Atom "Exists") [portray x]++-- N.B. we do actually want TestEquality rather than GEq here, because we want+-- to diff same-typed-but-not-equal values according to their Diff instances.+instance (TestEquality m, forall a. Portray (m a), forall a. Diff (m a))+      => Diff (Exists m) where+  diff (Exists x) (Exists y) = case testEquality x y of+    Just Refl -> diff x y+    Nothing   -> Just $ portray x `diffVs` portray y++instance Functor10 Exists where+  fmap10 f (Exists x) = Exists (f x)++instance Foldable10 Exists where+  foldMap10 f (Exists x) = f x++instance Traversable10 Exists where+  mapTraverse10 r f (Exists x) = r . Exists <$> f x
+ src/Data/Ten/Field.hs view
@@ -0,0 +1,213 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides 'Generic1' derivation of @Representable10@ based on 'Field10'.+--+-- Like with "Data.Functor.Field", we use parametric functions+-- @forall m. f m -> m a@ to identify positions tagged with type @a@ within+-- @f@.  This leads to instances for 'Data.Ten.Representable.Representable10'+-- and 'Data.Ten.Update.Update10'.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Field+         ( Field10(..)+         , FieldPaths10(..), GFieldPaths10(..)+         , Constrained10(..)+         ) where++import Control.Monad.Trans.State (state, evalState)+import Data.Coerce (coerce)+import Data.Functor ((<&>))+import Data.Functor.Const (Const(..))+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy(..))+import qualified Data.Text as T+import Data.Type.Equality (TestEquality(..), (:~:)(..))+import GHC.Generics+         ( Generic1(..)+         , (:*:)(..), (:.:)(..)+         , M1(..), Rec1(..), U1(..)+         , Meta(..), S, C, D+         )+import GHC.TypeLits (KnownSymbol, symbolVal)++import Data.GADT.Compare (GEq(..), GCompare(..), GOrdering(..))+import Data.Hashable (Hashable(..))+import Data.Portray (Portray(..), Portrayal(..))+import Data.Portray.Diff (Diff(..), diffVs)+import Data.Wrapped (Wrapped1(..))++import Data.Functor.Field (FieldPaths(..))+import Data.Ten.Ap (Ap10(..))+import Data.Ten.Applicative (Applicative10(..))+import Data.Ten.Entails (Entails(..), Dict1(..))+import Data.Ten.Functor (Functor10(..))+import Data.Ten.Internal+         ( PathComponent(..), dropUnderscore, showsPath, portrayPath+         )+import Data.Ten.Traversable (Traversable10, fsequenceA10)+import {-# SOURCE #-} Data.Ten.Update (Update10, EqualityTable(..), equalityTable)++-- | A 'Data.Ten.Representable.Rep10' type as a parametric accessor function.+newtype Field10 f a = Field10 { getField10 :: forall m. f m -> m a }++instance Update10 f => TestEquality (Field10 f) where+  testEquality (Field10 f) (Field10 g) = case f equalityTable of+    EqualityTable tbl -> unComp1 (g tbl)++instance Update10 f => GEq (Field10 f) where+  geq = testEquality++instance (Traversable10 f, Applicative10 f, Update10 f)+      => GCompare (Field10 f) where+  gcompare x y = case geq x y of+    Just Refl -> GEQ+    Nothing ->+      if getConst (getField10 x fieldNumbers) <+           getConst (getField10 y fieldNumbers)+        then GLT+        else GGT++fieldNumbers :: (Traversable10 f, Applicative10 f) => f (Const Int)+fieldNumbers =+  flip evalState 0 $+  fsequenceA10 (pure10 $ Comp1 $ state $ \i -> (Const i, i + 1))++instance (Traversable10 f, Applicative10 f) => Eq (Field10 f a) where+  Field10 x == Field10 y = x fieldNumbers == y fieldNumbers++instance (Traversable10 f, Applicative10 f) => Ord (Field10 f a) where+  Field10 x `compare` Field10 y = x fieldNumbers `compare` y fieldNumbers++instance (Traversable10 f, Applicative10 f) => Hashable (Field10 f a) where+  hashWithSalt salt (Field10 x) = hashWithSalt salt $ x fieldNumbers++instance FieldPaths10 f => Show (Field10 f a) where+  showsPrec p (Field10 f) = showParen (p > 10) $+    showString "Field10 " . showsPath 11 (coerce $ f fieldPaths10)++instance FieldPaths10 f => Portray (Field10 f a) where+  portray (Field10 f) = Apply "Field10" [portrayPath $ coerce $ f fieldPaths10]++instance (Traversable10 f, Applicative10 f, FieldPaths10 f)+      => Diff (Field10 f a) where+  diff f g+    | f == g    = Nothing+    | otherwise = Just $ portray f `diffVs` portray g++-- | Provides a path of field selectors / lenses identifying each "field".+class FieldPaths10 (rec :: (k -> Type) -> Type) where+  fieldPaths10 :: rec (Const [PathComponent])++instance (Generic1 rec, GFieldPaths10 (Rep1 rec))+      => FieldPaths10 (Wrapped1 Generic1 rec) where+  fieldPaths10 = Wrapped1 . to1 $ gfieldPaths10 Const+  {-# INLINE fieldPaths10 #-}++-- | 'Generic1' implementation of 'FieldPaths10'.+class GFieldPaths10 (rec :: (k -> Type) -> Type) where+  gfieldPaths10 :: (forall a. [PathComponent] -> r a) -> rec r++instance GFieldPaths10 U1 where+  gfieldPaths10 _ = U1+  {-# INLINE gfieldPaths10 #-}++instance FieldPaths10 (Ap10 a) where+  fieldPaths10 = Ap10 (Const [])+  {-# INLINE fieldPaths10 #-}++instance (Functor10 rec, FieldPaths10 rec) => GFieldPaths10 (Rec1 rec) where+  gfieldPaths10 r = Rec1 $ fmap10 (r . getConst) fieldPaths10+  {-# INLINE gfieldPaths10 #-}++instance GFieldPaths10 rec => GFieldPaths10 (M1 C i rec) where+  gfieldPaths10 r = M1 $ gfieldPaths10 r+  {-# INLINE gfieldPaths10 #-}++-- Non-newtype constructors: wait until we get to the fields to assign a path+-- component.+instance GFieldPaths10 rec => GFieldPaths10 (M1 D ('MetaData n m p 'False) rec) where+  gfieldPaths10 r = M1 $ gfieldPaths10 r+  {-# INLINE gfieldPaths10 #-}++-- Newtype constructors: immediately decide to use 'NewtypeIso'.+instance GFieldPaths10 rec+      => GFieldPaths10 (M1 D ('MetaData n m p 'True) (M1 C i (M1 S j rec))) where+  gfieldPaths10 r = M1 . M1 . M1 $ gfieldPaths10 (r . (NewtypeIso:))+  {-# INLINE gfieldPaths10 #-}++instance (KnownSymbol sym, GFieldPaths10 rec)+      => GFieldPaths10 (M1 S ('MetaSel ('Just sym) b c d) rec) where+  gfieldPaths10 r = M1 $ gfieldPaths10 $+    r . (NamedField (T.pack nm) (T.pack $ dropUnderscore nm) :)+   where+    nm = symbolVal @sym Proxy+  {-# INLINE gfieldPaths10 #-}++instance (GFieldPaths10 f, GFieldPaths10 g) => GFieldPaths10 (f :*: g) where+  gfieldPaths10 r = gfieldPaths10 r :*: gfieldPaths10 r+  {-# INLINE gfieldPaths10 #-}++instance (Functor f, FieldPaths f, GFieldPaths10 g)+      => GFieldPaths10 (f :.: g) where+  gfieldPaths10 r = Comp1 $+    fieldPaths <&> \outer ->+    gfieldPaths10 $ \inner ->+    r $ outer ++ inner+  {-# INLINE gfieldPaths10 #-}++-- | @Constrained10 c f@ means that in @f m@, all applications of @m@+-- are to types @x@ that satisfy constraint @c@.+class Constrained10 (c :: k -> Constraint) (f :: (k -> Type) -> Type) where+  -- | Recover instances of @c@ to accompany each @m@ element in @f@.+  constrained10 :: f (Dict1 c)++instance c a => Constrained10 c (Ap10 a) where+  constrained10 = Ap10 Dict1++instance (Generic1 f, Constrained10 c (Rep1 f))+      => Constrained10 c (Wrapped1 Generic1 f) where+  constrained10 = Wrapped1 $ to1 constrained10++instance Constrained10 c U1 where+  constrained10 = U1++deriving instance Constrained10 c f => Constrained10 c (Rec1 f)+deriving instance Constrained10 c f => Constrained10 c (M1 i c1 f)++instance (Constrained10 c f, Constrained10 c g)+      => Constrained10 c (f :*: g) where+  constrained10 = constrained10 :*: constrained10++instance (Applicative f, Constrained10 c g) => Constrained10 c (f :.: g) where+  constrained10 = Comp1 (pure constrained10)++instance (Constrained10 c f, Applicative10 f) => Entails (Field10 f) c where+  entailment (Field10 f) = f constrained10
+ src/Data/Ten/Foldable.hs view
@@ -0,0 +1,120 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides an analog of 'Foldable' over arity-1 type constructors.++{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Foldable+         ( Foldable10(..)+         , fold10, foldr10, foldl10, traverse10_, sequenceA10_, fsequenceA10_+         ) where++import Data.Functor (void)+import Data.Functor.Const (Const(..))+import Data.Kind (Type)+import Data.Monoid (Dual(..), Endo(..))+import GHC.Generics+         ( Generic1(..)+         , (:.:)(..), (:*:)(..), (:+:)(..)+         , M1(..), Rec1(..), U1(..), V1, K1(..)+         )++import Data.Wrapped (Wrapped1(..))++import Data.Ten.Ap (Ap10(..))++-- | 'Foldable' over arity-1 type constructors.+--+-- Whereas 'Foldable' folds @a :: Type@ values to a monoid, 'Foldable10' folds+-- @(m :: k -> Type) a@ values to a monoid, parametrically in @a@.  That is,+-- the type parameter of 'Foldable' has arity 0, and the type parameter of+-- 'Foldable10' has arity 1.+class Foldable10 (t :: (k -> Type) -> Type) where+  -- | Map each @m a@ element parametrically to @w@ and 'mconcat' the results.+  foldMap10 :: Monoid w => (forall a. m a -> w) -> t m -> w++instance (Generic1 f, Foldable10 (Rep1 f))+      => Foldable10 (Wrapped1 Generic1 f) where+  foldMap10 f = foldMap10 f . from1 . unWrapped1++instance Foldable10 (Ap10 a) where+  foldMap10 f (Ap10 x) = f x++instance Foldable10 (K1 i a) where+  foldMap10 _ (K1 _) = mempty++instance Foldable10 V1 where+  foldMap10 _ x = case x of {}++instance Foldable10 U1 where+  foldMap10 _ U1 = mempty++deriving instance Foldable10 f => Foldable10 (Rec1 f)+deriving instance Foldable10 f => Foldable10 (M1 i c f)++instance (Foldable10 f, Foldable10 g) => Foldable10 (f :+: g) where+  foldMap10 f (L1 x) = foldMap10 f x+  foldMap10 f (R1 x) = foldMap10 f x++instance (Foldable10 f, Foldable10 g) => Foldable10 (f :*: g) where+  foldMap10 f (l :*: r) = foldMap10 f l <> foldMap10 f r++instance (Foldable f, Foldable10 g) => Foldable10 (f :.: g) where+  foldMap10 f (Comp1 x) = foldMap (foldMap10 f) x++-- | Given a structure over @'Const' m@, return the ('<>') of all elements.+fold10 :: (Foldable10 t, Monoid m) => t (Const m) -> m+fold10 = foldMap10 getConst++-- | Right-associative fold over a 'Foldable10'.+foldr10 :: Foldable10 t => (forall a. m a -> b -> b) -> b -> t m -> b+foldr10 f z = flip appEndo z . foldMap10 (Endo . f)++-- | Left-associative fold over a 'Foldable10'.+foldl10 :: Foldable10 t => (forall a. b -> m a -> b) -> b -> t m -> b+foldl10 f z = flip appEndo z . getDual . foldMap10 (Dual . Endo . flip f)++-- | Sequence actions given by a function left-to-right in a 'Foldable10'.+--+-- This form discards the final result; see 'Data.Ten.Traversable.traverse10'+-- for a version that keeps it.+traverse10_+  :: (Applicative f, Foldable10 t) => (forall a. m a -> f ()) -> t m -> f ()+traverse10_ f = foldl10 (\a x -> a <* f x) (pure ())++-- | Sequence actions in a 'Foldable10' left-to-right, discarding the result.+--+-- This variant expects the composition of the 'Applicative' being sequenced+-- with some inner type constructor at each field.+--+-- See 'Data.Ten.Traversable.fsequenceA10_' for a version that keeps the result.+fsequenceA10_ :: (Applicative m, Foldable10 f) => f (m :.: n) -> m ()+fsequenceA10_ = traverse10_ (void . unComp1)++-- | Sequence actions in a 'Foldable10' left-to-right, discarding the result.+--+-- This variant expects just the plain @m@ actions with no inner type+-- constructor.+sequenceA10_ :: (Applicative m, Foldable10 f) => f m -> m ()+sequenceA10_ = traverse10_ void
+ src/Data/Ten/Foldable/WithIndex.hs view
@@ -0,0 +1,95 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | An extension of 'Foldable10' that provides access to some 'Index10'.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Data.Ten.Foldable.WithIndex+         ( Index10, Foldable10WithIndex(..)+         , ifoldl10, ifoldr10, itraverse10_+         , foldMap10C, foldr10C, foldl10C, traverse10C_+         ) where++import Data.Monoid (Dual(..), Endo(..))++import GHC.Generics ((:.:)(..))++import Data.Ten.Entails (Entails(..), byEntailment)+import Data.Ten.Foldable (Foldable10(..))+import Data.Ten.Functor.WithIndex (Index10)++-- | An extension of 'Foldable10' that provides access to some 'Index10'.+class Foldable10 f => Foldable10WithIndex f where+  ifoldMap10 :: Monoid w => (forall a. Index10 f a -> m a -> w) -> f m -> w++instance (Foldable g, Foldable10WithIndex f)+      => Foldable10WithIndex (g :.: f) where+  ifoldMap10 f (Comp1 gfm) = foldMap (ifoldMap10 f) gfm++-- | 'Data.Ten.Foldable.foldl10' with an index parameter.+ifoldl10+  :: Foldable10WithIndex f+  => (forall a. Index10 f a -> b -> m a -> b)+  -> b -> f m -> b+ifoldl10 f z fm = appEndo (ifoldMap10 (\i x -> Endo (\b -> f i b x)) fm) z++-- | 'Data.Ten.Foldable.foldr10' with an index parameter.+ifoldr10+  :: Foldable10WithIndex f+  => (forall a. Index10 f a -> m a -> b -> b) -> b -> f m -> b+ifoldr10 f z fm = flip appEndo z $ getDual $+  ifoldMap10 (\i x -> Dual $ Endo (f i x)) fm++-- | 'Data.Ten.Foldable.traverse10_' with an index parameter.+itraverse10_+  :: (Foldable10WithIndex f, Applicative g)+  => (forall a. Index10 f a -> m a -> g ())+  -> f m -> g ()+itraverse10_ f = ifoldl10 (\i a x -> a <* f i x) (pure ())++-- | 'Data.Ten.Foldable.foldMap10' with an instance for every element.+foldMap10C+  :: forall c f m w+   . (Entails (Index10 f) c, Foldable10WithIndex f, Monoid w)+  => (forall a. c a => m a -> w) -> f m -> w+foldMap10C f = ifoldMap10 (byEntailment @c f)++-- | 'Data.Ten.Foldable.foldr10' with an instance for every element.+foldr10C+  :: forall c f m b+   . (Entails (Index10 f) c, Foldable10WithIndex f)+  => (forall a. c a => m a -> b -> b) -> b -> f m -> b+foldr10C f = ifoldr10 (byEntailment @c f)++-- | 'Data.Ten.Foldable.foldl10' with an instance for every element.+foldl10C+  :: forall c f m b+   . (Entails (Index10 f) c, Foldable10WithIndex f)+  => (forall a. c a => b -> m a -> b) -> b -> f m -> b+foldl10C f = ifoldl10 (byEntailment @c f)++-- | 'Data.Ten.Foldable.traverse10_' with an instance for every element.+traverse10C_+  :: forall c f g m+   . (Entails (Index10 f) c, Applicative g, Foldable10WithIndex f)+  => (forall a. c a => m a -> g ()) -> f m -> g ()+traverse10C_ f = itraverse10_ (byEntailment @c f)
+ src/Data/Ten/Functor.hs view
@@ -0,0 +1,98 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides an analog of 'Functor' over arity-1 type constructors.++{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Functor+         ( Functor10(..), (<$!), (<$>!), void10+         ) where++import Data.Kind (Type)+import Data.Proxy (Proxy(..))+import GHC.Generics+         ( Generic1(..)+         , (:.:)(..), (:*:)(..), (:+:)(..)+         , M1(..), Rec1(..), U1(..), V1, K1(..)+         )++import Data.Wrapped (Wrapped1(..))++import Data.Ten.Ap (Ap10(..))++-- | 'Functor' over arity-1 type constructors.+--+-- Whereas 'Functor' maps @a :: Type@ values to @b :: Type@ values, 'Functor10'+-- maps @(m :: k -> Type) a@ values to @m b@ values, parametrically in @a@.+-- That is, the type parameter of 'Functor' has arity 0, and the type+-- parameter of 'Functor10' has arity 1.+class Functor10 (f :: (k -> Type) -> Type) where+  -- | Map each @m a@ value in @f m@ parametrically to @n a@ to get @f m@.+  fmap10 :: (forall a. m a -> n a) -> f m -> f n++instance (Generic1 f, Functor10 (Rep1 f))+      => Functor10 (Wrapped1 Generic1 f) where+  fmap10 f = Wrapped1 . to1 . fmap10 f . from1 . unWrapped1++instance Functor10 (Ap10 a) where+  fmap10 f (Ap10 x) = Ap10 (f x)++instance Functor10 (K1 i a) where+  fmap10 _ (K1 x) = K1 x++instance Functor10 V1 where+  fmap10 _ x = case x of {}++instance Functor10 U1 where+  fmap10 _ U1 = U1++deriving instance Functor10 f => Functor10 (Rec1 f)+deriving instance Functor10 f => Functor10 (M1 i c f)++instance (Functor10 f, Functor10 g) => Functor10 (f :+: g) where+  fmap10 f (L1 x) = L1 (fmap10 f x)+  fmap10 f (R1 x) = R1 (fmap10 f x)++instance (Functor10 f, Functor10 g) => Functor10 (f :*: g) where+  fmap10 f (l :*: r) = fmap10 f l :*: fmap10 f r++instance (Functor f, Functor10 g) => Functor10 (f :.: g) where+  fmap10 f (Comp1 x) = Comp1 $ fmap (fmap10 f) x++infixl 4 <$!+-- | ('<$') for 'Functor10'.+(<$!) :: Functor10 f => (forall a. n a) -> f m -> f n+x <$! f = fmap10 (const x) f++infixl 4 <$>!+-- | ('<$>') for 'Functor10'.+(<$>!) :: Functor10 f => (forall a. m a -> n a) -> f m -> f n+(<$>!) = fmap10++-- | 'Data.Functor.void' for 'Functor10'.+--+-- This returns @f 'Proxy'@ because @Proxy :: k -> Type@ has the right kind and+-- carries no runtime information.  It's isomorphic to @Const ()@ but easier to+-- spell.+void10 :: Functor10 f => f m -> f Proxy+void10 = fmap10 (const Proxy)
+ src/Data/Ten/Functor/WithIndex.hs view
@@ -0,0 +1,59 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | An extension of 'Functor10' that provides access to some 'Index10'.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Ten.Functor.WithIndex+         ( Index10+         , Functor10WithIndex(..), fmap10C+         ) where++import Data.Kind (Type)+import GHC.Generics ((:.:)(..))++import Data.Ten.Entails (Entails, byEntailment)+import Data.Ten.Functor (Functor10(..))++-- | The index type associated with a given @f@.+--+-- This is often a GADT-like type, in that inspecting @Index10 f a@ can refine+-- @a@ to some more concrete type, provide instances for it via 'Entails', etc.+type family Index10 (f :: (k -> Type) -> Type) :: k -> Type++type instance Index10 (g :.: f) = Index10 f++-- | An extension of 'Functor10' that provides access to some 'Index10'.+class Functor10 f => Functor10WithIndex f where+  imap10 :: (forall a. Index10 f a -> m a -> n a) -> f m -> f n++instance (Functor g, Functor10WithIndex f) => Functor10WithIndex (g :.: f) where+  imap10 f (Comp1 gfm) = Comp1 $ fmap (imap10 f) gfm++-- | 'fmap10' with access to an instance for every element.+fmap10C+  :: forall c f m n+   . (Entails (Index10 f) c, Functor10WithIndex f)+  => (forall a. c a => m a -> n a) -> f m -> f n+fmap10C f = imap10 (byEntailment @c f)
+ src/Data/Ten/Internal.hs view
@@ -0,0 +1,93 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Internal utilities used by multiple modules.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module Data.Ten.Internal where++import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics ((:*:)(..))++import Data.Portray (Portrayal(..), infixr_)++-- | The names of a lens and field selector, or @coerce@/@_Wrapped@.+--+-- Used in deriving 'Show'/'Text.PrettyPrint.HughesPJClass.Pretty' instances+-- for field selector newtypes.+data PathComponent+  = NewtypeIso+    -- ^ Zooming in on the contents of a newtype with @coerce@ or @_Wrapped@.+  | NamedField !Text !Text+    -- ^ Zooming in on a record field with the given named selector/lens.++-- | Convert a 'PathComponent' to a 'String', with a suffix.+showPathComponent :: PathComponent -> ShowS+showPathComponent NewtypeIso = showString "coerce"+showPathComponent (NamedField selectorName _lensName) =+  showString (T.unpack selectorName)++-- | Convert a list of 'PathComponent's to a 'String', a la 'showsPrec'.+showsPath :: Int -> [PathComponent] -> ShowS+showsPath p path = case reverse path of+  -- If the path ends up empty, that means either there's a bug, or we've added+  -- support to GHC for a new Generics representation type equivalent to Ap10,+  -- and we're looking at it as a standalone GFieldPaths00 instance.  Since+  -- that'll be a newtype, we'll represent it as "coerce", since that should+  -- work regardless of what it ends up being called.+  []     -> showString "coerce"+  [x]    -> showPathComponent x+  (x:xs) -> showParen (p > 9) $+    showPathComponent x .+    flip (foldr (\y -> showString " . " . showPathComponent y)) xs++-- | Pretty-print a 'PathComponent'.+portrayPathComponent :: PathComponent -> Portrayal+portrayPathComponent NewtypeIso = "coerce"+portrayPathComponent (NamedField selectorName _) = Atom selectorName++-- | Pretty-print a field path.+portrayPath :: [PathComponent] -> Portrayal+portrayPath path = go $ reverse path+ where+  go [] = "coerce"+  go [x] = portrayPathComponent x+  go (x:xs) =+    Binop "." (infixr_ 9) (portrayPathComponent x) $+    go xs++-- | Guess the name of the lens corresponding to a field.+dropUnderscore :: String -> String+dropUnderscore ('_':x) = x+dropUnderscore x = x++-- | Access the left side of a (':*:').+starFst :: (f :*: g) m -> f m+starFst (f :*: _) = f++-- | Access the right side of a (':*:').+starSnd :: (f :*: g) m -> g m+starSnd (_ :*: g) = g++-- | Modify the left side of a (':*:').+mapStarFst :: (f m -> f m) -> (f :*: g) m -> (f :*: g) m+mapStarFst h (f :*: g) = h f :*: g++-- | Modify the right side of a (':*:').+mapStarSnd :: (g m -> g m) -> (f :*: g) m -> (f :*: g) m+mapStarSnd h (f :*: g) = f :*: h g
+ src/Data/Ten/Representable.hs view
@@ -0,0 +1,196 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides an analog of @Representable@ over arity-1 type constructors.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Representable+         ( Representable10(..)+         , rep10', field10'+         , distributeRep10, collectRep10+         , GTabulate10(..)+         , index10C+         ) where++import Data.Coerce (coerce)+import Data.Functor.Const (Const(..))+import Data.Kind (Type)+import Data.Type.Equality ((:~:)(..))+import GHC.Generics+         ( Generic1(..)+         , (:.:)(..), (:*:)(..)+         , M1(..), Rec1(..), U1(..)+         )++import Data.Wrapped (Wrapped1(..))++import Data.Functor.Rep (Representable(..))+import Data.Ten.Ap (Ap10(..))+import Data.Ten.Applicative (Applicative10(..))+import Data.Ten.Entails (Entails(..), withEntailment)+import Data.Ten.Field (Field10(..))+import Data.Ten.Functor (Functor10(..))+import Data.Ten.Functor.WithIndex (Index10, Functor10WithIndex(..))+import Data.Ten.Foldable (Foldable10(..), fold10)+import Data.Ten.Foldable.WithIndex (Foldable10WithIndex(..))+import Data.Ten.Internal (starFst, starSnd)+import Data.Ten.Traversable (Traversable10(..))+import Data.Ten.Traversable.WithIndex (Traversable10WithIndex(..))++(.:) :: (q -> r) -> (a -> b -> q) -> a -> b -> r+(.:) = (.) . (.)++-- | Analog of 'Data.Functor.Rep.Representable' over arity-1 type constructors.+--+-- If @f@ is @Representable10@, then a value of type @f m@ is isomorphic to a+-- function @forall a. Rep10 f a -> m a@.  This essentially means it can be+-- thought of as a fixed-shape record with a wrapper type applied to all of its+-- fields.+--+-- This is also equivalent to a total dependent map from @Rep10 f@ to @m@+-- ("total" meaning that every "key" has a "value").+class Applicative10 f => Representable10 (f :: (k -> Type) -> Type) where+  -- | The "index" type of an @f@ "container".+  --+  -- This is a type that behaves like a GADT, with a value for each possible+  -- "position" of an @m a@ in @f m@ and the parameter type(s) @a@ it can have.+  type Rep10 f :: k -> Type++  -- | Given an @f m@ and a @Rep10 f a@ "index" into it, extract the @m a@.+  index10 :: f m -> Rep10 f a -> m a++  -- | Build an @f m@ by applying a parametric function to each "index".+  tabulate10 :: (forall a. Rep10 f a -> m a) -> f m++-- | Turn a record field selector into a 'Rep10'.+--+-- See also 'Data.Ten.Lens.rep10'.+rep10' :: Representable10 f => (f (Rep10 f) -> Rep10 f a) -> Rep10 f a+rep10' = ($ tabulate10 id)++-- | Turn a record field selector targeting 'Ap10' into a 'Rep10'.+--+-- See also 'Data.Ten.Lens.rep10'.+field10'+  :: Representable10 rec+  => (rec (Rep10 rec) -> Ap10 a (Rep10 rec)) -> Rep10 rec a+field10' f = rep10' (unAp10 . f)++-- | Superclass appeasement; deriving via this will give infinite loops; don't!+deriving via (f :: (k -> Type) -> Type)+  instance Functor10 f => Functor10 (Wrapped1 Representable10 f)++-- | Superclass appeasement; deriving via this will give infinite loops; don't!+deriving via (f :: (k -> Type) -> Type)+  instance Foldable10 f => Foldable10 (Wrapped1 Representable10 f)++-- | Superclass appeasement; deriving via this will give infinite loops; don't!+deriving via (f :: (k -> Type) -> Type)+  instance Traversable10 f => Traversable10 (Wrapped1 Representable10 f)++type instance Index10 (Wrapped1 Representable10 f) = Rep10 f++instance Representable10 f+      => Functor10WithIndex (Wrapped1 Representable10 f) where+  imap10 f (Wrapped1 fm) = Wrapped1 $ tabulate10 (\i -> f i (fm `index10` i))++instance (Representable10 f, Foldable10 f)+      => Foldable10WithIndex (Wrapped1 Representable10 f) where+  ifoldMap10 f fm = fold10 $ imap10 (Const .: f) fm++instance (Representable10 f, Traversable10 f)+      => Traversable10WithIndex (Wrapped1 Representable10 f) where+  imapTraverse10 r f fm = mapTraverse10 r unComp1 $ imap10 (Comp1 .: f) fm++-- | Analog of 'Data.Functor.Rep.distributeRep' for 'Representable10'.+--+-- Pulls a fixed record shape to the outside of any functor.+distributeRep10+  :: (Representable10 f, Functor w)+  => w (f m) -> f (w :.: m)+distributeRep10 wfm = tabulate10 (\r -> Comp1 $ (`index10` r) <$> wfm)++-- | Analog of 'Data.Functor.Rep.collectRep' for 'Representable10'.+--+-- Gathers a fixed record shape mapped over the elements of any functor.+collectRep10+  :: (Representable10 f, Functor w)+  => (a -> f m) -> w a -> f (w :.: m)+collectRep10 f wa = distributeRep10 (f <$> wa)++-- | The 'Generic1' implementation of 'tabulate10' based on 'Field10'.+class GTabulate10 (rec :: (k -> Type) -> Type) where+  gtabulate10 :: (forall a. Field10 rec a -> r a) -> rec r++instance Representable10 (Ap10 a) where+  type Rep10 (Ap10 a) = (:~:) a+  index10 (Ap10 x) Refl = x+  tabulate10 f = Ap10 (f Refl)++instance GTabulate10 U1 where+  gtabulate10 _ = U1+  {-# INLINE gtabulate10 #-}++instance Representable10 rec => GTabulate10 (Rec1 rec) where+  gtabulate10 r = Rec1 $+    tabulate10 (\i -> r (Field10 (\ (Rec1 f) -> index10 f i)))+  {-# INLINE gtabulate10 #-}++instance GTabulate10 rec => GTabulate10 (M1 k i rec) where+  gtabulate10 r = M1 $ gtabulate10 (r . coerce)++instance (GTabulate10 f, GTabulate10 g)+      => GTabulate10 (f :*: g) where+  gtabulate10 r = ftab :*: gtab+   where+    ftab = gtabulate10 $ \ (Field10 g) -> r $ Field10 $ g . starFst+    gtab = gtabulate10 $ \ (Field10 g) -> r $ Field10 $ g . starSnd+  {-# INLINE gtabulate10 #-}++instance (Representable f, GTabulate10 g) => GTabulate10 (f :.: g) where+  gtabulate10 r = Comp1 $+    tabulate $ \ i ->+    gtabulate10 $ \ (Field10 g) ->+    r $ Field10 (g . flip index i . unComp1)+  {-# INLINE gtabulate10 #-}++instance (Generic1 rec, Applicative10 (Rep1 rec), GTabulate10 (Rep1 rec))+      => Representable10 (Wrapped1 Generic1 rec) where+  type Rep10 (Wrapped1 Generic1 rec) = Field10 rec+  index10 (Wrapped1 rec) (Field10 f) = f rec+  tabulate10 f =+    Wrapped1 $ to1 $ gtabulate10 $ \i -> f $ Field10 $ getField10 i . from1++-- | Access an element along with an instance for its type parameter.+index10C+  :: forall c f a r m+   . (Representable10 f, Entails (Rep10 f) c)+  => f m -> Rep10 f a -> (c a => m a -> r) -> r+index10C fm k f = withEntailment @c k $ f (index10 fm k)
+ src/Data/Ten/Sigma.hs view
@@ -0,0 +1,238 @@+-- Copyright 2019-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | An approximation of a dependent pair type.++module Data.Ten.Sigma+         ( (:**)(..), overFragment, lmapFragment, eqKey+         , OpCostar(..), caseFragment+         ) where++import Data.Functor.Contravariant (Contravariant(..))+import Data.Maybe (fromMaybe, isJust)+import Data.Type.Equality ((:~:)(Refl), TestEquality(..))++import Control.DeepSeq (NFData(..))+import Data.GADT.Compare (GEq(..))+import Data.Portray (Portray(..), Portrayal(..), infixr_)+import Data.Portray.Diff (Diff(..), diffVs)++import Data.Ten.Entails ((:!:), Entails, withEntailment)+import Data.Ten.Foldable (Foldable10(..))+import Data.Ten.Foldable.WithIndex (Foldable10WithIndex(..))+import Data.Ten.Functor (Functor10(..))+import Data.Ten.Functor.WithIndex (Index10, Functor10WithIndex(..))+import Data.Ten.Representable (Representable10(..))+import Data.Ten.Traversable (Traversable10(..))+import Data.Ten.Traversable.WithIndex (Traversable10WithIndex(..))+import Data.Ten.Update (Update10, overRep10)++infixr 5 :**+-- | A pair of @k a@ and @m a@ for any (existential) @a@.+--+-- This is a lot like a dependent pair, in that it contains a left-hand-side+-- value that's meant to identify a type, and a right-hand-side parameterized+-- by that type.  For example, the true dependent pair type (in e.g. Idris)+-- @(n :: Nat ** Vec n Bool)@ could be approximated in Haskell as+-- @SInt :** Ap10 Bool Vec@.+--+-- This can be used to represent one field of a 'Representable10', where @k@ is+-- set to @Rep10 f@.  The @k a@ identifies which field (and locks down its+-- type), and the @m a@ provides its value.+data k :** m = forall a. k a :** m a++instance (forall a. NFData (k a), Entails k (NFData :!: m))+      => NFData (k :** m) where+  rnf (k :** m) = withEntailment @(NFData :!: m) k $ rnf k `seq` rnf m++instance (GEq k, Entails k (Eq :!: m))+      => Eq (k :** m) where+  (kl :** ml) == (kr :** mr) = case geq kl kr of+     Nothing -> False+     Just Refl -> withEntailment @(Eq :!: m) kl $ ml == mr++{-+instance ( Arbitrary (Exists k)+         , Representable10 rec, Entails k (Arbitrary :!: m)+         )+      => Arbitrary (k :** m) where+  arbitrary = do+    Exists k <- arbitrary+    a <- withEntailment @(Arbitrary :!: m) k arbitrary+    return $ k :** a+-}++instance (forall a. Show (k a), Entails k (Show :!: m))+      => Show (k :** m) where+  -- We have to write this by hand because the derived version doesn't know how+  -- to call into 'Constrained10' to find a 'Show' instance for @a@ based on+  -- @ka@.+  showsPrec p (ka :** ma) = showParen (p > prec) $+    showsPrec (1+prec) ka .+    showString " :** " .+    withEntailment @(Show :!: m) ka (showsPrec (1+prec) ma)+   where+    prec = 5++instance (forall a. Portray (k a), Entails k (Portray :!: m))+      => Portray (k :** m) where+  portray (ka :** ma) = withEntailment @(Portray :!: m) ka $+    Binop ":**" (infixr_ 5) (portray ka) (portray ma)++instance ( TestEquality k, forall a. Portray (k a), forall a. Diff (k a)+         , Entails k (Portray :!: m), Entails k (Diff :!: m)+         )+      => Diff (k :** m) where+  diff (ka :** ma) (kb :** mb) = case testEquality ka kb of+    Just Refl -> withEntailment @(Diff :!: m) ka $+      case (diff ka kb, diff ma mb) of+        (Nothing, Nothing) -> Nothing+        (dk, dm) ->+          Just $ Binop ":**" (infixr_ 5)+            (fromMaybe (portray ka) dk)+            (fromMaybe "_" dm)+    Nothing   -> Just $+      withEntailment @(Portray :!: m) ka (portray (ka :** ma)) `diffVs`+      withEntailment @(Portray :!: m) kb (portray (kb :** mb))++instance Functor10 ((:**) k) where fmap10 f (k :** m) = k :** f m+instance Foldable10 ((:**) k) where foldMap10 f (_ :** m) = f m+instance Traversable10 ((:**) k) where+  mapTraverse10 r f (k :** m) = r . (k :**) <$> f m++type instance Index10 ((:**) k) = k+instance Functor10WithIndex ((:**) k) where imap10 f (k :** m) = k :** f k m+instance Foldable10WithIndex ((:**) k) where ifoldMap10 f (k :** m) = f k m+instance Traversable10WithIndex ((:**) k) where+  imapTraverse10 r f (k :** m) = r . (k :**) <$> f k m++-- | Check if two pairs have the same key.+eqKey :: GEq k => k :** m -> k :** n -> Bool+eqKey (kl :** _) (kr :** _) = isJust (geq kl kr)++-- | "Zip" a single field of a record with a (':**').+--+-- Since we're only operating on a single field, the @n@ type can't vary like+-- in a traditional zip function.+overFragment+  :: Update10 rec+  => (forall a. m a -> n a -> n a) -> Rep10 rec :** m -> rec n -> rec n+overFragment f (k :** x) = overRep10 k (f x)++-- | Newtype used in implementing contravariant conversion of Fragments.  See+-- 'lmapFragment'.  Only exported because it's used in the type of+-- 'lmapFragment', but it can be largely ignored, like the many "ALens" etc.+-- types in "lens".+newtype OpCostar f r a = OpCostar { getOpCostar :: f a -> r }++instance Functor f => Contravariant (OpCostar f r) where+  contramap f (OpCostar g) = OpCostar (g . fmap f)++-- | Simulate a case statement on a (':**') with a record of functions.+--+-- @+--     caseFragment (MyRecord1 (OpCostar isJust) (OpCostar isNothing)) x+-- @+--+-- Is analogous to (pseudo-code):+--+-- @+--     case x of { (_mr1A :** mx) -> isJust mx; (_mr1B :** mx) -> isNothing mx }+-- @+--+-- This is just the action of `Representable10` (whereby @f m@ is isomorphic to+-- @forall a. Rep10 f a -> m a@) plus some newtyping:+--+-- @+--     f (OpCostar m r)                      ~=  (by Representable10)+--     forall a. Rep10 f a -> OpCostar m r a ~=  (by newtype)+--     forall a. Rep10 f a -> f a -> r       ~=  (by GADT constructor)+--     Rep10 f :** m -> r+-- @+caseFragment+  :: Representable10 f+  => f (OpCostar m r)+  -> Rep10 f :** m -> r+caseFragment fco (k :** v) = getOpCostar (fco `index10` k) v++-- | Convert a (':**') to a different key type contravariantly.+--+-- Example usage:+--+--     data MyRecord1 m = MyRecord1 { _mr1A :: Ap10 Int m, _mr1B :: Ap10 Int m }+--     data MyRecord2 m = MyRecord2 { _mr2A :: Ap10 Int m }+--+--     -- Collapse both fields _mr1A and _mr1B onto _mr2A.+--     example+--       :: Rep10 MyRecord1 :** Identity+--       -> Rep10 MyRecord2 :** Identity+--     example = lmapFragment $ \MyRecord2{..} -> MyRecord1+--       { _mr1A = _mr2A+--       , _mr1B = _mr2A+--       }+--+-- It looks weird that the argument converts from @recB@ to @recA@ in order+-- to convert (':**') the other way, so it merits some explanation: first,+-- note that, by @'Representable10' recA@, we know that @recA m@ is+-- isomorphic to @forall a. 'Rep10' recA a -> m a@.  That is, @Rep10 recA@+-- effectively appears in negative position in @recA m@.  So, a function from+-- @recB@ to @recA@ hand-wavingly contains a function in the opposite+-- direction from @Rep10 recA@ to @Rep10 recB@.+--+-- With the intuition out of the way, here's how we actually accomplish the+-- conversion: start off with a record @recB@ where each field is a function+-- that trivially rebuilds the corresponding @(:**)@ in each field with+-- @k :: Rep10 recB@ we literally just put @(k :**)@ with the appropriate+-- newtype constructors.  Then, apply the user's contravariant conversion+-- function, to turn our @recB@ of @recB@-pair-builders into an+-- @recA@ of @recB@-pair-builders.  If the user-provided conversion+-- function involves changing any field types, it must have done so by+-- @contramap@ping the pair-builders: instead of a function that just+-- directly applies @(k :=)@ to its argument, they will now contain functions+-- equivalent to @\ma -> k := _f ma@.  Finally, unpack the @recA@ pair+-- and use its @k@ to fetch that field's @recB@-pair-builder (potentially+-- with a conversion inserted at the front), and apply it to the payload.+--+-- Usage will typically involve applying contramap to some number of fields and+-- leaving the rest unchanged.  If you have a type-changing+-- 'Control.Lens.Setter' at hand, it's probably easier to use+-- 'Data.Ten.Lens.fragmented'.+lmapFragment+  :: forall recA recB m f+   . ( Representable10 recA, Representable10 recB+     , f ~ OpCostar m (Rep10 recB :** m)+     )+  => (recB f -> recA f)+  -> Rep10 recA :** m -> Rep10 recB :** m+lmapFragment f = caseFragment fragmentBuilders+ where+  fragmentBuilders :: recA (OpCostar m (Rep10 recB :** m))+  fragmentBuilders = f (tabulate10 (\k' -> OpCostar (k' :**)))
+ src/Data/Ten/Traversable.hs view
@@ -0,0 +1,147 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides an analog of 'Traversable' over arity-1 type constructors.++{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Traversable+         ( Traversable10(..), traverse10, sequenceA10, fsequenceA10+         ) where++import Data.Coerce (coerce)+import Data.Functor.Identity (Identity(..))+import Data.Kind (Type)+import GHC.Generics+         ( Generic1(..)+         , (:.:)(..), (:*:)(..), (:+:)(..)+         , M1(..), Rec1(..), U1(..), V1, K1(..)+         )++import Data.Wrapped (Wrapped1(..))++import Data.Ten.Ap (Ap10(..))+import Data.Ten.Foldable (Foldable10)+import Data.Ten.Functor (Functor10)++(.:) :: (q -> r) -> (a -> b -> q) -> a -> b -> r+(.:) = (.) . (.)++-- | Analog of 'Traversable' over arity-1 type constructors.+--+-- This is defined in terms of 'mapTraverse10' for two reasons:+--+-- * First, it makes it possible to use with GeneralizedNewtypeDeriving and+--   DerivingVia.  See+--   https://ryanglscott.github.io/2018/06/22/quantifiedconstraints-and-the-trouble-with-traversable/+--   for more details.+-- * Second, it uses fewer 'fmap's in some cases: when you need to re-apply a+--   constructor tag like 'L1' or 'R1' after calling 'traverse10' on the+--   payload, this would normally be an additional 'fmap', but with+--   'mapTraverse10' it can be fused into the underlying recursive call.  Less+--   crucially, the same trick applies when traversing multiple fields and+--   combining them back into a product type: the first call can use+--   'mapTraverse10' to pre-apply the function, and use '<*>' rather than+--   'Control.Applicative.liftA2' (which is often defined as an 'fmap' followed+--   by a '<*>').+class (Functor10 t, Foldable10 t)+   => Traversable10 (t :: (k -> Type) -> Type) where+  -- | 'traverse10' with a built-in 'fmap' on the final result.+  mapTraverse10+    :: forall f m n r+     . Applicative f+    => (t n -> r)+    -> (forall a. m a -> f (n a))+    -> t m -> f r++-- | Analog of 'traverse' for functors over arity-1 type constructors.+--+-- Given a parametric function that takes the wrapped type @m a@ to @n a@ in an+-- 'Applicative' @f@, visit all contained @m _@s to convert from @t m@ to @t n@.+--+-- @m@ and @n@ here play the role of @a@ and @b@ in the normal 'traverse' type;+-- that is, instead of traversing to change a @Type@, we're traversing to change+-- a type constructor of kind @k -> Type@:+--+-- @+--     traverse+--       :: (Traversable t, Applicative f)+--       => (          a   -> f  b   ) -> t a -> f (t b)+--     traverse10+--       :: (Traversable10 t, Applicative f)+--       => (forall x. m x -> f (n x)) -> t m -> f (t n)+-- @+traverse10+  :: forall t f m n+   . (Traversable10 t, Applicative f)+  => (forall a. m a -> f (n a))+  -> t m -> f (t n)+traverse10 = mapTraverse10 id++instance (Generic1 f, Traversable10 (Rep1 f))+      => Traversable10 (Wrapped1 Generic1 f) where+  mapTraverse10 r f = mapTraverse10 (r . Wrapped1 . to1) f . from1 . unWrapped1++instance Traversable10 (Ap10 a) where+  mapTraverse10 r f (Ap10 x) = r . Ap10 <$> f x++instance Traversable10 (K1 i a) where+  mapTraverse10 r _ k = pure (r $ coerce k)++instance Traversable10 V1 where+  mapTraverse10 _ _ x = case x of {}++instance Traversable10 U1 where+  mapTraverse10 r _ U1 = pure (r U1)++instance Traversable10 f => Traversable10 (Rec1 f) where+  mapTraverse10 r f (Rec1 x) = mapTraverse10 (r . Rec1) f x++instance Traversable10 f => Traversable10 (M1 i c f) where+  mapTraverse10 r f (M1 x) = mapTraverse10 (r . M1) f x++instance (Traversable10 f, Traversable10 g) => Traversable10 (f :+: g) where+  mapTraverse10 r f (L1 x) = mapTraverse10 (r . L1) f x+  mapTraverse10 r f (R1 x) = mapTraverse10 (r . R1) f x++instance (Traversable10 f, Traversable10 g) => Traversable10 (f :*: g) where+  mapTraverse10 r f (x :*: y) =+    mapTraverse10 (r .: (:*:)) f x <*> traverse10 f y++instance (Traversable f, Traversable10 g) => Traversable10 (f :.: g) where+  mapTraverse10 r f (Comp1 x) = r . Comp1 <$> traverse (traverse10 f) x++-- | 'sequenceA' for 'Traversable10'.+--+-- This variant expects just the plain @m@ actions at each field, and wraps the+-- results in @Identity.+sequenceA10+  :: (Applicative m, Traversable10 f)+  => f m -> m (f Identity)+sequenceA10 = traverse10 (fmap Identity)++-- | 'sequenceA' for 'Traversable10'.+--+-- This variant expects the composition of the 'Applicative' being sequenced+-- with some inner type constructor at each field.+fsequenceA10+  :: (Applicative m, Traversable10 f)+  => f (m :.: n) -> m (f n)+fsequenceA10 = traverse10 coerce
+ src/Data/Ten/Traversable/WithIndex.hs view
@@ -0,0 +1,64 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | An extension of 'Traversable10' that provides access to some 'Index10'.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Data.Ten.Traversable.WithIndex+         ( Index10, Traversable10WithIndex(..), itraverse10+         , traverse10C+         ) where++import GHC.Generics ((:.:)(..))++import Data.Ten.Entails (Entails(..), byEntailment)+import Data.Ten.Foldable.WithIndex (Foldable10WithIndex(..))+import Data.Ten.Functor.WithIndex (Index10, Functor10WithIndex(..))+import Data.Ten.Traversable (Traversable10(..))++-- | An extension of 'Traversable10' that provides access to some 'Index10'.+class (Functor10WithIndex f, Foldable10WithIndex f, Traversable10 f)+   => Traversable10WithIndex f where+  imapTraverse10+    :: Applicative g+    => (f n -> r)+    -> (forall a. Index10 f a -> m a -> g (n a))+    -> f m -> g r++instance (Traversable g, Traversable10WithIndex f)+      => Traversable10WithIndex (g :.: f) where+  imapTraverse10 r f (Comp1 gfm) =+    r . Comp1 <$> traverse (imapTraverse10 id f) gfm++-- | 'Data.Ten.Traversable.traverse10' with an index parameter.+itraverse10+  :: (Applicative g, Traversable10WithIndex f)+  => (forall a. Index10 f a -> m a -> g (n a))+  -> f m -> g (f n)+itraverse10 = imapTraverse10 id++-- | 'Data.Ten.Traversable.traverse10' with an instance for every element.+traverse10C+  :: forall c f g m n+   . (Entails (Index10 f) c, Applicative g, Traversable10WithIndex f)+  => (forall a. c a => m a -> g (n a)) -> f m -> g (f n)+traverse10C f = itraverse10 (byEntailment @c f)
+ src/Data/Ten/Update.hs view
@@ -0,0 +1,141 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Extends 'Representable10' with support for modifying elements.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Ten.Update+         ( Update10(..), updateRep10, ixRep10, FieldSetter10(..)+         , EqualityTable(..), equalityTable+         , GUpdate10(..)+         ) where++import Data.Functor ((<&>))+import Data.Kind (Type)+import Data.Type.Equality ((:~:)(..))+import GHC.Generics+         ( Generic1(..)+         , (:*:)(..), (:.:)(..)+         , M1(..), Rec1(..), U1(..)+         )++import Data.Wrapped (Wrapped1(..))++import Data.Functor.Rep (Representable(..))++import Data.Functor.Update (Update(..))+import Data.Ten.Ap (Ap10(..))+import Data.Ten.Applicative (Applicative10(..))+import Data.Ten.Field (Field10(..))+import Data.Ten.Internal (mapStarFst, mapStarSnd)+import Data.Ten.Representable (Representable10(..), GTabulate10(..))++-- | Extends 'Representable10' with support for modifying elements.+--+-- See also 'Data.Functor.Update.Update'.+class Representable10 f => Update10 (f :: (k -> Type) -> Type) where+  -- | Modify an @f m@ at a given index.+  overRep10 :: Rep10 f a -> (m a -> m a) -> f m -> f m++-- | Update an @f m@ at a given index.+updateRep10 :: Update10 f => Rep10 f a -> m a -> f m -> f m+updateRep10 i = overRep10 i . const++-- | A 'Control.Lens.Lens' to the field identified by a given 'Rep10'.+--+-- @+--     ix10 :: Update10 f => Rep10 f a -> Lens' (f m) (m a)+-- @+ixRep10+  :: (Update10 f, Functor g)+  => Rep10 f a -> (m a -> g (m a)) -> f m -> g (f m)+ixRep10 i f = \fm -> f (index10 fm i) <&> \fma -> updateRep10 i fma fm++-- | A newtype wrapper to store tables of equality witnesses in @f@.+newtype EqualityTable f a = EqualityTable (f (Maybe :.: ((:~:) a)))++-- | Implementation detail of @'Data.Type.Equality.TestEquality' ('Field10' f)@.+--+-- This is a pre-populated table of @'Maybe' (a ':~:' b)@s, with 'Just's in the+-- elements where the inner position is the same as the outer position, i.e.+-- along the "diagonal".  Then we can test two @forall m. f m -> m a@ functions+-- for equality, by applying them in turn to the two layers of @f@, and see if+-- we reach a 'Just' or a 'Nothing'.+equalityTable :: Update10 f => f (EqualityTable f)+equalityTable = tabulate10 $ \i -> EqualityTable $+  updateRep10 i (Comp1 (Just Refl)) (pure10 (Comp1 Nothing))++instance ( Generic1 f+         , Applicative10 (Rep1 f), GTabulate10 (Rep1 f), GUpdate10 (Rep1 f)+         )+      => Update10 (Wrapped1 Generic1 f) where+  overRep10 =+    \i f (Wrapped1 fm) -> Wrapped1 $ runFS10 (getField10 i setters) f fm+   where+     -- Superstition-based optimization: try to make GHC specialize 'setters10'+     -- to @f@ exactly once per instance of 'Update10'.+     setters :: f (FieldSetter10 f)+     setters = setters10++-- | 'Generic1' implementation of 'Update10'.+class GUpdate10 (rec :: (k -> Type) -> Type) where+  gsetters10+    :: (forall a. (forall m. (m a -> m a) -> rec m -> rec m) -> r a)+    -> rec r++instance Update10 (Ap10 a) where+  overRep10 Refl f (Ap10 x) = Ap10 (f x)+  {-# INLINE overRep10 #-}++instance GUpdate10 U1 where+  gsetters10 _ = U1+  {-# INLINE gsetters10 #-}++instance Update10 rec => GUpdate10 (Rec1 rec) where+  gsetters10 r = Rec1 $ tabulate10 $+    \i -> r (\f -> Rec1 . overRep10 i f . unRec1)+  {-# INLINE gsetters10 #-}++instance GUpdate10 rec => GUpdate10 (M1 k i rec) where+  gsetters10 r = M1 $ gsetters10 (\s -> r $ \f -> M1 . s f . unM1 )+  {-# INLINE gsetters10 #-}++instance (GUpdate10 f, GUpdate10 g) => GUpdate10 (f :*: g) where+  gsetters10 r = fs :*: gs+   where+    fs = gsetters10 $ \s -> r $ mapStarFst . s+    gs = gsetters10 $ \s -> r $ mapStarSnd . s+  {-# INLINE gsetters10 #-}++instance (Update f, GUpdate10 g) => GUpdate10 (f :.: g) where+  gsetters10 r = Comp1 $+    tabulate $ \ i ->+    gsetters10 $ \ s ->+    r $ \f -> Comp1 . overRep i (s f) . unComp1+  {-# INLINE gsetters10 #-}++-- | A newtype wrapper to store field modifier functions in @f@.+newtype FieldSetter10 f a = FS10+  { runFS10 :: forall m. (m a -> m a) -> f m -> f m }++setters10 :: (Generic1 f, GUpdate10 (Rep1 f)) => f (FieldSetter10 f)+setters10 = to1 $ gsetters10 (\overI -> FS10 $ \f -> to1 . overI f . from1)
+ src/Data/Ten/Update.hs-boot view
@@ -0,0 +1,29 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module Data.Ten.Update (Update10, EqualityTable(..), equalityTable) where++import Data.Kind (Type)+import Data.Type.Equality ((:~:)(..))+import GHC.Generics ((:.:)(..))++class Update10 (f :: (k -> Type) -> Type)++newtype EqualityTable f a = EqualityTable (f (Maybe :.: ((:~:) a)))++equalityTable :: Update10 f => f (EqualityTable f)
+ ten.cabal view
@@ -0,0 +1,105 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 420a8fd5dab8b49f35524f82502e9d7f80fabffd59b9a3c7d9cfbf5999c83618++name:           ten+version:        0.1.0.0+synopsis:       Typeclasses like Functor, etc. over arity-1 type constructors.+description:    This provides a mirror of the traditional typeclass hierarchy for types of+                kind @(k -> Type) -> Type@, or functors from the category __Hask{k}__ to+                __Hask__, where __Hask{k}__ denotes the category whose objects are mappings+                from @k@ to @Type@, and whose morphisms are the parametric functions between+                them.  In general, these functors look like variations on the theme of+                "polymorphic records", also frequently described as "higher-kinded data".+                .+                We currently provide the following classes, which correspond directly to+                their equivalents in "base" or "adjunctions": 'Functor10', 'Foldable10',+                'Traversable10', 'Applicative10', and 'Representable10'.  Additionally, a+                class 'Constrained10' provides instances for the argument of each occurrence+                of the type parameter in a value.+category:       Data+homepage:       https://github.com/google/hs-ten#readme+bug-reports:    https://github.com/google/hs-ten/issues+author:         Andrew Pritchard <awpr@google.com>, Reiner Pope <reinerp@google.com>++maintainer:     Andrew Pritchard <awpr@google.com>+copyright:      2018-2021 Google LLC+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/google/hs-ten+  subdir: ten++library+  exposed-modules:+      Data.Functor.Field+      Data.Functor.Update+      Data.Ten+      Data.Ten.Ap+      Data.Ten.Applicative+      Data.Ten.Entails+      Data.Ten.Exists+      Data.Ten.Field+      Data.Ten.Foldable+      Data.Ten.Foldable.WithIndex+      Data.Ten.Functor+      Data.Ten.Functor.WithIndex+      Data.Ten.Internal+      Data.Ten.Representable+      Data.Ten.Sigma+      Data.Ten.Traversable+      Data.Ten.Traversable.WithIndex+      Data.Ten.Update+  other-modules:+      Paths_ten+  hs-source-dirs:+      src+  build-depends:+      adjunctions >=4.0 && <4.5+    , base >=4.12 && <4.16+    , data-default-class >=0.0 && <0.2+    , deepseq >=1.1 && <1.5+    , distributive >=0.1 && <0.7+    , hashable >=1.0 && <1.4+    , portray >=0.1 && <0.2+    , portray-diff >=0.1 && <0.2+    , some >=1.0 && <1.1+    , text >=0.1 && <1.3+    , transformers >=0.0.1 && <0.6+    , wrapped >=0.1 && <0.2+  default-language: Haskell2010++test-suite Traversable10-test+  type: exitcode-stdio-1.0+  main-is: Traversable10Test.hs+  other-modules:+      Paths_ten+  hs-source-dirs:+      test+  build-depends:+      HUnit+    , adjunctions >=4.0 && <4.5+    , base >=4.12 && <4.16+    , data-default-class >=0.0 && <0.2+    , deepseq >=1.1 && <1.5+    , distributive >=0.1 && <0.7+    , hashable >=1.0 && <1.4+    , portray >=0.1 && <0.2+    , portray-diff >=0.1 && <0.2+    , some >=1.0 && <1.1+    , ten+    , test-framework+    , test-framework-hunit+    , text >=0.1 && <1.3+    , transformers >=0.0.1 && <0.6+    , wrapped >=0.1 && <0.2+  default-language: Haskell2010
+ test/Traversable10Test.hs view
@@ -0,0 +1,152 @@+-- Copyright 2018-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--      http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Control.DeepSeq (NFData(..))+import Data.Functor.Const (Const(..))+import Data.Functor.Identity (Identity(..))+import Data.Monoid (Sum(..))+import GHC.Generics (Generic, Generic1)++import Data.Default.Class (Default(..))+import Data.Distributive (Distributive(..))+import Data.Functor.Field (FieldRep(..))+import Data.Functor.Update (Update)+import Data.Functor.Rep (Representable(..), distributeRep)+import Data.Hashable (Hashable(..))+import Data.Portray (Portray)+import Data.Portray.Diff (Diff)+import Data.Ten+         ( Functor10(..), Foldable10(..), Traversable10+         , Applicative10(..), Constrained10, Representable10, Update10+         , Ap10(..)+         )+import Data.Wrapped (Wrapped1(..), Wrapped(..))++import Test.HUnit.Lang (assertEqual)+import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (testCase)++data Pair a = Pair a a+  deriving+    ( Functor, Foldable, Traversable+    , Eq, Ord, Read, Show, Hashable, Default, NFData+    , Generic, Generic1+    )+  deriving (Representable, Update, Applicative, Monad) via FieldRep Pair+  deriving (Portray, Diff) via Wrapped Generic (Pair a)++instance Distributive Pair where distribute = distributeRep++data Foo f = Foo+  { x :: Ap10 Word f+  , y :: Ap10 String f+  , z :: Ap10 Double f+  , w :: Pair (Ap10 Int f)+  }+  deriving (Eq, Ord, Read, Show, Hashable, Default, NFData, Generic, Generic1)+  deriving (Portray, Diff) via Wrapped Generic (Foo f)+  deriving+    ( Foldable10, Traversable10, Constrained10 c+    , Functor10, Applicative10, Representable10, Update10+    ) via Wrapped1 Generic1 Foo++type BasicFoo = Foo Identity+type MaybeFoo = Foo Maybe+type BoolFoo = Foo (Const Bool)++data Bar f = Bar+  { ordinaryField :: Ap10 Int f+  , nestedField :: Foo f+  }+  deriving (Eq, Ord, Read, Show, Hashable, Default, NFData, Generic, Generic1)+  deriving (Portray, Diff) via Wrapped Generic (Bar f)+  deriving+    ( Foldable10, Traversable10, Constrained10 c+    , Functor10, Applicative10, Representable10, Update10+    ) via Wrapped1 Generic1 Bar++justAll :: BasicFoo -> MaybeFoo+justAll = fmap10 (Just . runIdentity)++applyMask :: BoolFoo -> BasicFoo -> MaybeFoo+applyMask =+  liftA210 (\(Const b) (Identity a) -> if b then Just a else Nothing)++popcntMask :: BoolFoo -> Int+popcntMask =+  getSum . foldMap10 (\(Const b) -> Sum (if b then 1 else 0))++--++cFalse, cTrue :: Ap10 a (Const Bool)+cFalse = Ap10 (Const False)+cTrue = Ap10 (Const True)++theMask :: BoolFoo+theMask = Foo {+  x = cFalse,+  y = cTrue,+  z = cTrue,+  w = Pair cTrue cFalse+ }++fNothing :: Ap10 a Maybe+fNothing = Ap10 Nothing++fJust :: a -> Ap10 a Maybe+fJust a = Ap10 (Just a)++masked :: MaybeFoo+masked = Foo {+  x = fNothing,+  y = fJust "y",+  z = Ap10 (Just 456.0),+  w = Pair (fJust 6) fNothing+ }++val :: a -> Ap10 a Identity+val a = Ap10 (Identity a)++basic :: BasicFoo+basic = Foo {+  x = val 123,+  y = val "y",+  z = val 456.0,+  w = Pair (val 6) (val 7)+ }++{- HLINT ignore main "Use list literal" -}+main :: IO ()+main = defaultMain $+  testCase "popcntMask" (+    assertEqual "" 3 (popcntMask theMask)+  ) :+  testCase "applyMask" (+    assertEqual "" masked (applyMask theMask basic)) :+  []