diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for large-anon +## 0.2.1 -- 2023-07-05 + +* Add `distribute` (Johannes Gerer, #142) + ## 0.2 -- 2023-03-06 * Do not generate imports in the plugin (#129). diff --git a/large-anon.cabal b/large-anon.cabal --- a/large-anon.cabal +++ b/large-anon.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-anon -version: 0.2 +version: 0.2.1 synopsis: Scalable anonymous records description: The @large-anon@ package provides support for anonymous records in Haskell, with a focus on compile-time (and @@ -12,7 +12,7 @@ category: Records extra-source-files: CHANGELOG.md test/Test/Sanity/RebindableSyntax/Tests.hs -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 library exposed-modules: diff --git a/src/Data/Record/Anon/Advanced.hs b/src/Data/Record/Anon/Advanced.hs --- a/src/Data/Record/Anon/Advanced.hs +++ b/src/Data/Record/Anon/Advanced.hs @@ -48,6 +48,8 @@ , cmapM , sequenceA , sequenceA' + , distribute + , distribute' -- ** Zipping , zip , zipWith @@ -412,6 +414,23 @@ -- | Simplified form of 'sequenceA' sequenceA' :: Applicative m => Record m r -> m (Record I r) sequenceA' = A.sequenceA' + +-- | Distribute +-- +-- This is a higher kinded version of @distribute@ from +-- , and inverse to +-- 'sequenceA'. +-- +-- Be careful with this function: if @f@ allows effects, then those effects will +-- be duplicated whenever any field of the resulting record is accessed. Using +-- this with @f == Vector@ or @f == Maybe@ is fine, but you almost certainly +-- don't want to use it with @f == IO@, for example. +distribute :: (Functor m, KnownFields r) => m (Record f r) -> Record (m :.: f) r +distribute = A.distribute + +-- | Simplified form of 'distribute'. +distribute' :: (Functor m, KnownFields r) => m (Record I r) -> Record m r +distribute' = A.distribute' -- | Analogue of 'Prelude.zip' zip :: Record f r -> Record g r -> Record (Product f g) r diff --git a/src/Data/Record/Anon/Internal/Advanced.hs b/src/Data/Record/Anon/Internal/Advanced.hs --- a/src/Data/Record/Anon/Internal/Advanced.hs +++ b/src/Data/Record/Anon/Internal/Advanced.hs @@ -53,6 +53,8 @@ , cmapM , sequenceA , sequenceA' + , distribute + , distribute' -- ** Zipping , zip , zipWith @@ -339,6 +341,27 @@ sequenceA' = sequenceA . co where co :: Record m r -> Record (m :.: I) r + co = noInlineUnsafeCo + +distribute :: forall r m f. + (Functor m, KnownFields r) + => m (Record f r) -> Record (m :.: f) r +distribute = + unsafeFromCanonical + . Canon.fromList + . (\cs -> fieldVec cs <$> indices) + . fmap toCanonical + where + indices :: [Int] + indices = [0 .. pred (length $ proxy fieldNames (Proxy @r))] + + fieldVec :: m (Canonical f) -> Int -> (m :.: f) Any + fieldVec cs idx = Comp $ flip Canon.getAtIndex idx <$> cs + +distribute' :: (Functor m, KnownFields r) => m (Record I r) -> Record m r +distribute' = co . distribute + where + co :: Record (m :.: I) r -> Record m r co = noInlineUnsafeCo pure :: forall f r. KnownFields r => (forall x. f x) -> Record f r diff --git a/test/Test/Prop/Record/Combinators/Simple.hs b/test/Test/Prop/Record/Combinators/Simple.hs --- a/test/Test/Prop/Record/Combinators/Simple.hs +++ b/test/Test/Prop/Record/Combinators/Simple.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Test.Prop.Record.Combinators.Simple (tests) where @@ -9,6 +11,7 @@ import Data.Bifunctor import Data.SOP +import qualified Data.Record.Anon as Anon import qualified Data.Record.Anon.Advanced as Anon import Test.Tasty @@ -21,15 +24,16 @@ tests :: TestTree tests = testGroup "Test.Prop.Record.Combinators.Simple" [ - testProperty "map" test_map - , testProperty "mapM" test_mapM - , testProperty "zip" test_zip - , testProperty "zipWith" test_zipWith - , testProperty "zipWithM" test_zipWithM - , testProperty "collapse" test_collapse - , testProperty "sequenceA" test_sequenceA - , testProperty "pure" test_pure - , testProperty "ap" test_ap + testProperty "map" test_map + , testProperty "mapM" test_mapM + , testProperty "zip" test_zip + , testProperty "zipWith" test_zipWith + , testProperty "zipWithM" test_zipWithM + , testProperty "collapse" test_collapse + , testProperty "sequenceA" test_sequenceA + , testProperty "pure" test_pure + , testProperty "ap" test_ap + , testProperty "distribute" test_distribute ] {------------------------------------------------------------------------------- @@ -39,6 +43,13 @@ pTop :: Proxy Top pTop = Proxy +data Pair a = MkPair a a + deriving (Show, Eq, Functor) + +instance Applicative Pair where + pure x = MkPair x x + MkPair f1 f2 <*> MkPair x1 x2 = MkPair (f1 x1) (f2 x2) + {------------------------------------------------------------------------------- Tests proper -------------------------------------------------------------------------------} @@ -141,3 +152,27 @@ f :: K Int x -> (K Int -.-> K Int) x f (K x) = fn $ \(K y) -> K (x + y) + +-- | Test 'Anon.distribute' +-- +-- We do not have a model implementation, but instead test that +-- 'Anon.distribute' is right inverse to 'Anon.sequenceA'. +test_distribute :: + SomeRecordPair (K Int) (K Int) + -> Property +test_distribute = \(SR2 fields r1 r2) -> + Modl.fieldsKnown fields $ + go fields r1 r2 + where + go :: forall r. + Anon.KnownFields r + => Modl.ModelFields r + -> Modl.ModelRecord (K Int) r + -> Modl.ModelRecord (K Int) r + -> Property + go fields r1 r2 = + rs + === Anon.sequenceA (Anon.distribute rs) + where + rs :: Pair (Anon.Record (K Int) r) + rs = MkPair (Modl.toRecord fields r1) (Modl.toRecord fields r2) diff --git a/test/Test/Prop/Record/Model.hs b/test/Test/Prop/Record/Model.hs --- a/test/Test/Prop/Record/Model.hs +++ b/test/Test/Prop/Record/Model.hs @@ -34,6 +34,7 @@ -- * Constraints , ModelSatisfies , satisfyAll + , fieldsKnown -- * Conversion to/from 'Record' , toRecord , fromRecord @@ -70,6 +71,7 @@ import Data.Record.Anon import Data.Record.Anon.Advanced (Record) + import qualified Data.Record.Anon.Advanced as Anon {------------------------------------------------------------------------------- @@ -122,6 +124,12 @@ satisfyAll _ MF1 k = k satisfyAll _ MF2 k = k satisfyAll _ MF2' k = k + +fieldsKnown :: ModelFields r -> (KnownFields r => a) -> a +fieldsKnown MF0 k = k +fieldsKnown MF1 k = k +fieldsKnown MF2 k = k +fieldsKnown MF2' k = k {------------------------------------------------------------------------------- Conversion from/to model