flay 0.2 → 0.3

raw patch · 7 files changed

+98/−101 lines, 7 filesdep +transformersdep −ghc-primPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependencies removed: ghc-prim

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• default.nix +1/−2
• flay.cabal +2/−2
• pkg.nix +3/−3
• release.nix +6/−24
• shell.nix +1/−2
• src/Flay.hs +73/−68

@@ -1,3 +1,15 @@+# Version 0.3++* `zip`, `zip1` and `unsafeZip` now take a monadic pairing function, and return+  `Maybe` where `Nothing` happens in the target indexes do not match.++* Added `trivialize`.++* Generalized type of `trivial'`.++* Remove `Record` and `GRecord`.++ # Version 0.2  * BREAKING CHANGE: The `m` parameter in in `Flay` and `Flayable` has been

@@ -1,2 +1,1 @@-{ compiler ? "ghc822" }:-(import ./release.nix {}).${compiler}.flay+(import ./release.nix {}).flay

@@ -1,5 +1,5 @@ name: flay-version: 0.2+version: 0.3 author: Renzo Carbonara maintainer: renλren!zone copyright: Renzo Carbonara 2017@@ -28,7 +28,7 @@   build-depends:     base >=4.9 && <5.0,     constraints,-    ghc-prim+    transformers  test-suite tests   default-language: Haskell2010

@@ -1,10 +1,10 @@-{ mkDerivation, base, constraints, ghc-prim, stdenv, tasty, tasty-quickcheck+{ mkDerivation, base, constraints, stdenv, tasty, tasty-quickcheck, transformers }: mkDerivation {   pname = "flay";-  version = "0.2";+  version = "0.3";   src = ./.;-  libraryHaskellDepends = [ base constraints ghc-prim ];+  libraryHaskellDepends = [ base constraints transformers ];   testHaskellDepends = [ base tasty tasty-quickcheck ];   homepage = "https://github.com/k0001/flay";   description = "Work on your datatype without knowing its shape nor its contents";

@@ -1,30 +1,12 @@-{ nixpkgsBootstrap ? <nixpkgs>-, nixpkgs ? (import nixpkgsBootstrap {}).fetchFromGitHub {-    owner = "NixOS";-    repo = "nixpkgs-channels";-    rev = "3eccd0b11d176489d69c778f2fcb544438f3ab56"; # unstable, dec 4 2017-    sha256 = "1i3p5m0pnn86lzni5y1win0sacckw3wlg9kqaw15nszhykgz22zq"; }+{ nixpkgs ? builtins.fetchTarball channel:nixos-18.03 }:  let pkgs = import nixpkgs {};--hsPackageSetConfig = self: super: {-  flay = self.callPackage (import ./pkg.nix) {};-};--x = {-  ghc802 = pkgs.haskell.packages.ghc802.override { packageSetConfig = hsPackageSetConfig; };-  ghc822 = pkgs.haskell.packages.ghc822.override { packageSetConfig = hsPackageSetConfig; };+ghc841 = pkgs.haskell.packages.ghc841.override {+  packageSetConfig = self: super: {+    flay = super.callPackage ./pkg.nix {};+  }; }; -in rec {-  ghc802 = { inherit (x.ghc802) flay; };-  ghc822 = { inherit (x.ghc822) flay; };--  everything = pkgs.releaseTools.aggregate {-    name = "everything";-    meta.description = "Every job in release.nix";-    constituents = [ ghc802.flay ghc822.flay ];-  };-}+in { inherit (ghc841) flay; }

@@ -1,2 +1,1 @@-{ compiler ? "ghc822" }:-(import ./release.nix {}).${compiler}.flay.env+(import ./default.nix).env

@@ -15,10 +15,10 @@ {-# LANGUAGE UndecidableSuperClasses #-}  -- | The most commonly used names in this module are intended to be imported--- unqualified:+-- unqualified, as necessary: -- -- @--- import Flay (Flay, Flayable(flay), gflay, Dict(Dict))+-- import Flay (Flay, Flayable(flay), Flayable1(flay1)) -- @ -- -- The rest of the names, qualified:@@ -39,6 +39,7 @@  -- ** Utils  , All  , Trivial+ , trivialize  , trivial  , trivial1  , trivial'@@ -48,8 +49,6 @@  , zip  , zip1  , unsafeZip- , Record- , GRecord  , terminal  , Terminal  , GTerminal(gterminal)@@ -57,22 +56,18 @@  , Dict(Dict)  ) where -import Control.Monad.ST (ST, runST)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State (StateT(StateT), runStateT)+import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)+import Data.Constraint (Constraint, Dict(Dict))+import Data.Dynamic (Dynamic, toDyn, fromDynamic)+import Data.Functor.Product (Product(Pair)) import Data.Functor.Const (Const(Const, getConst)) import Data.Functor.Identity (Identity(runIdentity))-import Data.Constraint (Constraint, Dict(Dict))-import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import Data.Typeable (Typeable) import qualified GHC.Generics as G import Prelude hiding (zip)-import Unsafe.Coerce (unsafeCoerce) -#if MIN_VERSION_ghc_prim(0,5,1)-import GHC.Types (Any)-#else-import GHC.Prim (Any)-#endif-- --------------------------------------------------------------------------------  -- | @'Flay' c s t f g@ allows converting @s@ to @t@ by replacing@@ -400,6 +395,13 @@ class Trivial (a :: k) instance Trivial (a :: k) +-- | Given a 'Flay' for any constraint @c@ obtain a 'Flay' for a 'Trivial'+-- constraint.+trivialize :: forall c s t f g. Flay c s t f g -> Flay Trivial s t f g+{-# INLINE trivialize #-}+trivialize fl0 = \h s ->+  fl0 (\(Dict :: Dict (c a)) (fa :: f a) -> h (Dict :: Dict (Trivial a)) fa) s+ -- | You can use 'trivial'' if you don't care about the @c@ argument to 'Flay'. -- This implies that you won't be able to observe the @a@ in @forall a. f a@, -- all you can do with such @a@ is pass it around.@@ -409,13 +411,13 @@ --    = fl (\\('Dict' :: 'Dict' ('Trivial' a)) (fa :: f a) -> h fa) -- @ trivial'-  :: forall m s t f g+  :: forall m c s t f g   .  Applicative m-  => Flay Trivial s t f g+  => Flay c s t f g   -> (forall a. Trivial a => f a -> m (g a))   -> s   -> m t  -- ^-trivial' fl = \h -> \s -> fl (\Dict fa -> h fa) s+trivial' fl = \h -> \s -> trivialize fl (\Dict fa -> h fa) s {-# INLINE trivial' #-}  -- | Like 'trivial'', but works on a 'Flayable' instead of taking an explicit@@ -425,11 +427,12 @@ -- 'trivial' = 'trivial'' 'flay' -- @ trivial-  :: (Applicative m, Flayable Trivial s t f g)+  :: forall m s t f g+  .  (Applicative m, Flayable Trivial s t f g)   => (forall a. Trivial a => f a -> m (g a))   -> s   -> m t  -- ^-trivial = trivial' flay+trivial = trivial' (flay :: Flay Trivial s t f g) {-# INLINE trivial #-}  -- | Like 'trivial'', but works on a 'Flayable1' instead of taking an explicit@@ -439,11 +442,12 @@ -- 'trivial' = 'trivial'' 'flay1' -- @ trivial1-  :: (Applicative m, Flayable1 Trivial r)+  :: forall m f g r+  .  (Applicative m, Flayable1 Trivial r)   => (forall a. Trivial a => f a -> m (g a))   -> (r f)   -> m (r g)  -- ^-trivial1 = trivial' flay1+trivial1 = trivial' (flay1 :: Flay Trivial (r f) (r g) f g) {-# INLINE trivial1 #-}  --------------------------------------------------------------------------------@@ -529,20 +533,6 @@  -------------------------------------------------------------------------------- --- | Handwavy class of which only product or record types are supposed to be--- instances.-class Record a-instance {-# OVERLAPPABLE #-} (G.Generic a, GRecord (G.Rep a)) => Record a--class GRecord (a :: * -> *) where-instance GRecord G.U1-instance GRecord (G.K1 r x)-instance GRecord x => GRecord (G.M1 i j x)-instance (GRecord l, GRecord r) => GRecord (l G.:*: r)------------------------------------------------------------------------------------ -- | Witness that @a@ is a terminal object. That is, that @a@ can always be -- constructed out of thin air. class Terminal a where@@ -594,57 +584,71 @@ -- Foo ('Const' \"(0,1)\") ('Const' \"False\") -- @ --+-- Returns 'Nothing' in case the indivual target types do not match.+-- -- Note: 'zip1' is safer but less general than 'unsafeZip'. zip1-  :: (Record (s f), Flayable1 c s)-  => (forall x. Dict (c x) -> f x -> g x -> h x)+  :: (Monad m, Typeable f, Flayable1 c s, Flayable1 Typeable s)+  => (forall x. Dict (c x) -> f x -> g x -> m (h x))   -> s f   -> s g-  -> s h  -- ^-zip1 h = unsafeZip flay1 flay1 h+  -> m (Maybe (s h))  -- ^+zip1 h = unsafeZip flay1 flay1 flay1 h {-# INLINABLE zip1 #-}  -- | Zip two 'Flayable's together. -- -- 'zip' is like 'zip1', but for 'Flayable's. --+-- Returns 'Nothing' in case the indivual target types do not match.+-- -- Note: 'zip' is safer but less general than 'unsafeZip'. zip-  :: ( Record s0-     , Flayable c s0 t0 f (Const ())-     , Flayable c s1 t1 g h )-  => (forall x. Dict (c x) -> f x -> g x -> h x)-  -> s0+  :: ( Monad m, Typeable f+     , Flayable Typeable s1 t1 f (Const ())+     , Flayable Typeable s2 t2 g (Product f g)+     , Flayable c t2 t3 (Product f g) h )+  => (forall x. Dict (c x) -> f x -> g x -> m (h x))   -> s1-  -> t1   -- ^-zip h = unsafeZip flay flay h+  -> s2+  -> m (Maybe t3)   -- ^+zip h = unsafeZip flay flay flay h {-# INLINABLE zip #-}  -- | Unsafe version of 'zip' that doesn't guarantee that the given 'Flay's--- target the same values. 'zip' makes this function safe by simply using--- 'flay' twice.+-- target the same values. 'zip' and 'zip1' make this function safe by simply+-- using 'flay' or 'flay1' three times.+--+-- Returns 'Nothing' in case the indivual target types do not match.++-- This implementation traverses the record three times. We could make it in+-- two, but that pollutes the constraints a bit. unsafeZip-  :: forall c s0 s1 t0 t1 f g h-  .  Record s0-  => (Flay c s0 t0 f (Const ()))-  -> (Flay c s1 t1 g h)-  -> (forall x. Dict (c x) -> f x -> g x -> h x)-  -> s0+  :: forall c s1 s2 t1 t2 t3 f g h m+  .  (Monad m, Typeable f)+  => (Flay Typeable s1 t1 f (Const ()))+  -> (Flay Typeable s2 t2 g (Product f g))+  -> (Flay c t2 t3 (Product f g) h)+  -> (forall x. Dict (c x) -> f x -> g x -> m (h x))   -> s1-  -> t1  -- ^-unsafeZip fl0 fl1 pair = \s0 s1 -> runST $ do-    r <- newSTRef (collect' fl0 f1 s0)-    fl1 (f2 r) s1-  where-    f1 :: Dict (c a) -> f a -> [Any]-    f1 = \Dict fa -> [unsafeCoerce fa :: Any]-    f2 :: STRef z [Any] -> Dict (c a) -> g a -> ST z (h a)-    f2 r = \Dict !ga -> do-       (x:xs) <- readSTRef r-       writeSTRef r xs-       let !fa = unsafeCoerce (x :: Any) :: f a-       pure $! pair Dict fa ga+  -> s2+  -> m (Maybe t3)  -- ^+unsafeZip fl1 fl2 fl3 pair = \s1 s2 -> runMaybeT $ do+   (t2, dyns) <- runStateT (fl2 f2 s2) (collect' fl1 f1 s1)+   case dyns of+     [] -> lift (fl3 f3 t2)+     _  -> MaybeT (pure Nothing)+ where+   f1 :: Dict (Typeable a) -> f a -> [Dynamic]+   f1 = \Dict !fa -> [toDyn fa :: Dynamic]+   f2 :: Dict (Typeable a) -> g a -> StateT [Dynamic] (MaybeT m) (Product f g a)+   f2 = \Dict !ga -> StateT $ \(x:xs) -> do+      !(fa :: f a) <- MaybeT (pure (fromDynamic x))+      pure (Pair fa ga, xs)+   f3 :: Dict (c a) -> Product f g a -> m (h a)+   f3 = \Dict (Pair fa ga) -> pair Dict fa ga + --------------------------------------------------------------------------------  -- | Ensure that @x@ satisfies all of the constraints listed in @cs@.@@ -657,3 +661,4 @@ type family All' (cs :: [k -> Constraint]) (x :: k) :: Constraint where   All' (c ': cs) x = (c x, All' cs x)   All' '[] _ = ()+