diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/src/Data/Functor/Field.hs b/src/Data/Functor/Field.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Field.hs @@ -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 #-} + -} diff --git a/src/Data/Functor/Update.hs b/src/Data/Functor/Update.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Update.hs @@ -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) diff --git a/src/Data/Ten.hs b/src/Data/Ten.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten.hs @@ -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 +-- +-- 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 diff --git a/src/Data/Ten/Ap.hs b/src/Data/Ten/Ap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Ap.hs @@ -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) diff --git a/src/Data/Ten/Applicative.hs b/src/Data/Ten/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Applicative.hs @@ -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 diff --git a/src/Data/Ten/Entails.hs b/src/Data/Ten/Entails.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Entails.hs @@ -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 diff --git a/src/Data/Ten/Exists.hs b/src/Data/Ten/Exists.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Exists.hs @@ -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 diff --git a/src/Data/Ten/Field.hs b/src/Data/Ten/Field.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Field.hs @@ -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 diff --git a/src/Data/Ten/Foldable.hs b/src/Data/Ten/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Foldable.hs @@ -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 diff --git a/src/Data/Ten/Foldable/WithIndex.hs b/src/Data/Ten/Foldable/WithIndex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Foldable/WithIndex.hs @@ -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) diff --git a/src/Data/Ten/Functor.hs b/src/Data/Ten/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Functor.hs @@ -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) diff --git a/src/Data/Ten/Functor/WithIndex.hs b/src/Data/Ten/Functor/WithIndex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Functor/WithIndex.hs @@ -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) diff --git a/src/Data/Ten/Internal.hs b/src/Data/Ten/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Internal.hs @@ -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 diff --git a/src/Data/Ten/Representable.hs b/src/Data/Ten/Representable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Representable.hs @@ -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) diff --git a/src/Data/Ten/Sigma.hs b/src/Data/Ten/Sigma.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Sigma.hs @@ -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' :**))) diff --git a/src/Data/Ten/Traversable.hs b/src/Data/Ten/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Traversable.hs @@ -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 diff --git a/src/Data/Ten/Traversable/WithIndex.hs b/src/Data/Ten/Traversable/WithIndex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Traversable/WithIndex.hs @@ -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) diff --git a/src/Data/Ten/Update.hs b/src/Data/Ten/Update.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Update.hs @@ -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) diff --git a/src/Data/Ten/Update.hs-boot b/src/Data/Ten/Update.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/Ten/Update.hs-boot @@ -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) diff --git a/ten.cabal b/ten.cabal new file mode 100644 --- /dev/null +++ b/ten.cabal @@ -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 , Reiner Pope + +maintainer: Andrew Pritchard +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 diff --git a/test/Traversable10Test.hs b/test/Traversable10Test.hs new file mode 100644 --- /dev/null +++ b/test/Traversable10Test.hs @@ -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)) : + []