proton 0.0.1 → 0.0.2

raw patch · 20 files changed

+465/−10 lines, 20 filesdep +asyncdep +foldsdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: async, folds, transformers

API changes (from Hackage documentation)

Files

• proton.cabal +16/−2
• src/Control/Arrow/Profunctor.hs +38/−0
• src/Data/Profunctor/Absorbent.hs +21/−0
• src/Data/Profunctor/Arrow.hs +181/−0
• src/Data/Profunctor/Cont.hs +79/−0
• src/Data/Profunctor/Expansive.hs +25/−0
• src/Data/Profunctor/Extras.hs +22/−0
• src/Data/Profunctor/Fold.hs +4/−0
• src/Data/Profunctor/FoldM.hs +16/−0
• src/Data/Profunctor/Joinable.hs +16/−0
• src/Data/Profunctor/Phantom.hs +9/−0
• src/Data/Profunctor/Remember.hs +1/−0
• src/Proton.hs +1/−0
• src/Proton/Fold.hs +2/−0
• src/Proton/Getter.hs +11/−6
• src/Proton/Par.hs +10/−0
• src/Proton/Prisms.hs +0/−1
• src/Proton/Review.hs +1/−1
• src/Proton/Telescope.hs +8/−0
• src/Proton/Traversal.hs +4/−0

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: de218e5a99e5d137be7685d7249aafd9d954cdc83f2bcdd1366a114fe7791ff2+-- hash: bc3bb1a1d076ef409f5f5a0f66bee82c1a27a49c71558e0dcbbea40781ac2a16  name:           proton-version:        0.0.1+version:        0.0.2 description:    Please see the README on GitHub at <https://github.com/ChrisPenner/proton#readme> homepage:       https://github.com/ChrisPenner/proton#readme bug-reports:    https://github.com/ChrisPenner/proton/issues@@ -27,16 +27,25 @@  library   exposed-modules:+      Control.Arrow.Profunctor       Data.Market       Data.Pair+      Data.Profunctor.Absorbent       Data.Profunctor.Annotated+      Data.Profunctor.Arrow       Data.Profunctor.Coindexed+      Data.Profunctor.Cont       Data.Profunctor.Depending       Data.Profunctor.Distributing       Data.Profunctor.DoubleStar       Data.Profunctor.Expanding+      Data.Profunctor.Expansive       Data.Profunctor.Extraction+      Data.Profunctor.Extras+      Data.Profunctor.Fold+      Data.Profunctor.FoldM       Data.Profunctor.Indexed+      Data.Profunctor.Joinable       Data.Profunctor.MStrong       Data.Profunctor.Phantom       Data.Profunctor.Reflector@@ -71,11 +80,13 @@       Proton.Lens       Proton.Loop       Proton.Miso+      Proton.Par       Proton.Plated       Proton.PreGrate       Proton.Prisms       Proton.Review       Proton.Setter+      Proton.Telescope       Proton.Traversal       Proton.Types       Proton.Wither@@ -87,6 +98,7 @@   ghc-options: -Wall   build-depends:       adjunctions+    , async     , base >=4.7 && <5     , bifunctors     , comonad@@ -94,8 +106,10 @@     , containers     , contravariant     , distributive+    , folds     , linear     , mtl     , profunctors >=5.5.1     , tagged+    , transformers   default-language: Haskell2010

@@ -0,0 +1,38 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+module Control.Arrow.Profunctor where++import Data.Profunctor+import qualified Data.Profunctor.Arrow as PA+import qualified Control.Arrow as Arr+import qualified Control.Category as C+import Data.Coerce+import Data.Bifunctor++newtype WrappedProfunctor p a b = WrappedProfunctor {unwrapProfunctor :: p a b}+  deriving newtype C.Category++instance (Profunctor p, C.Category p, Strong p) => Arr.Arrow (WrappedProfunctor p) where+  arr = WrappedProfunctor . PA.arr+  first (WrappedProfunctor p) = WrappedProfunctor (first' p)+  second (WrappedProfunctor p) = WrappedProfunctor (second' p)+  WrappedProfunctor l *** WrappedProfunctor r = WrappedProfunctor (l PA.*** r)+  WrappedProfunctor l &&& WrappedProfunctor r = WrappedProfunctor (l PA.&&& r)++instance (PA.ProfunctorZero p, C.Category p, Strong p) => Arr.ArrowZero (WrappedProfunctor p) where+  zeroArrow = WrappedProfunctor PA.zeroProfunctor++instance (PA.ProfunctorPlus p, C.Category p, Strong p) => Arr.ArrowPlus (WrappedProfunctor p) where+  WrappedProfunctor l <+> WrappedProfunctor r = WrappedProfunctor (l PA.<+> r)++instance (Choice p, C.Category p, Strong p) => Arr.ArrowChoice (WrappedProfunctor p) where+  left (WrappedProfunctor l) = WrappedProfunctor (left' l)+  right (WrappedProfunctor l) = WrappedProfunctor (right' l)+  WrappedProfunctor l +++ WrappedProfunctor r = WrappedProfunctor (l PA.+++ r)+  WrappedProfunctor l ||| WrappedProfunctor r = WrappedProfunctor (l PA.||| r)++instance (C.Category p, Strong p, PA.ProfunctorApply p) => Arr.ArrowApply (WrappedProfunctor p) where+  app  = WrappedProfunctor (lmap (first coerce) PA.app)++instance (C.Category p, Strong p, Costrong p) => Arr.ArrowLoop (WrappedProfunctor p) where+  loop (WrappedProfunctor p) = WrappedProfunctor (unfirst p)

@@ -0,0 +1,21 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Data.Profunctor.Absorbent where++import Data.Profunctor+import Data.Functor.Identity+import Control.Monad++-- Similar to Profunctor Representable, but simpler to implement and less restrictive+-- Represents Profunctors which can run effects.+class Profunctor p => Absorbent m p | p -> m where+  absorb :: p a (m b) -> p a b++instance Absorbent Identity (->) where+  absorb p = runIdentity . p++instance Monad m => Absorbent m (Star m) where+  absorb (Star f) = Star (join . f)++instance Absorbent m (Forget (m r)) where+  absorb (Forget f) = Forget f

@@ -0,0 +1,181 @@+{-# LANGUAGE ConstraintKinds #-}+module Data.Profunctor.Arrow where++import qualified Control.Category as C+import qualified Control.Arrow as Arr+import Data.Profunctor+import Data.Profunctor.Cayley+import Data.Profunctor.Strong+import Data.Profunctor.Closed+import Data.Profunctor.Choice+import Data.Profunctor.Traversing+import Data.Profunctor.Mapping+import Data.Profunctor.Yoneda+import Data.Profunctor.Ran+import Data.Profunctor.Composition++import Data.Bifunctor.Biff+import Data.Bifunctor.Tannen+import Data.Bifunctor.Joker+import Data.Bifunctor.Product+import Control.Applicative hiding (WrappedArrow(..))+++arr :: (Profunctor p, C.Category p) => (a -> b) -> p a b+arr f = rmap f C.id++-- | Split the input between the two argument profunctors and combine their output.+(***) :: (C.Category p, Strong p) => p b c -> p b' c' -> p (b, b') (c, c')+l *** r = first' l C.. second' r++-- | Fanout: send the input to both argument arrows and combine their output.+(&&&) :: (C.Category p, Strong p) => p b c -> p b c' -> p b (c, c')+l &&& r =  lmap (\x -> (x, x)) (l *** r)++-- | Precomposition with a pure function.+(^>>) :: (Profunctor p, C.Category p) => (b -> c) -> p c d -> p b d+f ^>> p = arr f C.>>> p++-- | Postcomposition with a pure function.+(>>^) :: (Profunctor p, C.Category p) => p b c -> (c -> d) -> p b d+p >>^ f = p C.>>> arr f++-- | Precomposition with a pure function (right-to-left variant).+(<<^) :: (Profunctor p, C.Category p) => p c d -> (b -> c) -> p b d+p <<^ f = p C.<<< arr f++-- | Postcomposition with a pure function (right-to-left variant).+(^<<) :: (Profunctor p, C.Category p) => (c -> d) -> p b c -> p b d+f ^<< p = arr f C.<<< p++(+++) :: (Choice p, C.Category p) => p b c -> p b' c' -> p (Either b b') (Either c c')+l +++ r = left' l C.<<< right' r++(|||) :: (Choice p, C.Category p) => p b d -> p c d -> p (Either b c) d+l ||| r = rmap (either id id) (l +++ r)++class Profunctor p => ProfunctorZero p where+  zeroProfunctor :: p a b++instance Alternative f => ProfunctorZero (Star f) where+  zeroProfunctor = Star (const empty)++instance (Monad m, Alternative m) => ProfunctorZero (Arr.Kleisli m) where+  zeroProfunctor = Arr.Kleisli (const empty)++instance Monoid r => ProfunctorZero (Forget r) where+  zeroProfunctor = Forget (const mempty)++instance (Applicative f, ProfunctorZero p) => ProfunctorZero (Cayley f p) where+  zeroProfunctor = Cayley (pure zeroProfunctor)++instance (Applicative f, ProfunctorZero p) => ProfunctorZero (Tannen f p) where+  zeroProfunctor = Tannen (pure zeroProfunctor)++instance (ProfunctorZero p) => ProfunctorZero (Tambara p) where+  zeroProfunctor = Tambara zeroProfunctor++instance (ProfunctorZero p) => ProfunctorZero (Closure p) where+  zeroProfunctor = Closure zeroProfunctor++instance (ProfunctorZero p) => ProfunctorZero (TambaraSum p) where+  zeroProfunctor = TambaraSum zeroProfunctor++instance (ProfunctorZero p) => ProfunctorZero (CofreeTraversing p) where+  zeroProfunctor = CofreeTraversing zeroProfunctor++instance (ProfunctorZero p) => ProfunctorZero (CofreeMapping p) where+  zeroProfunctor = CofreeMapping zeroProfunctor++instance (ProfunctorZero p) => ProfunctorZero (Yoneda p) where+  zeroProfunctor = Yoneda (\_ _ -> zeroProfunctor)++instance Alternative f => ProfunctorZero (Joker f) where+  zeroProfunctor = Joker empty++instance Arr.ArrowZero p => ProfunctorZero (WrappedArrow p) where+  zeroProfunctor = WrapArrow Arr.zeroArrow++instance ProfunctorZero p => ProfunctorZero (Codensity p) where+  zeroProfunctor = Codensity (const zeroProfunctor)++instance (ProfunctorZero p, ProfunctorZero q) => ProfunctorZero (Product p q) where+  zeroProfunctor = Pair zeroProfunctor zeroProfunctor++instance  (Profunctor p, ProfunctorZero q) => ProfunctorZero (Rift p q) where+  zeroProfunctor = Rift (const zeroProfunctor)++instance  (ProfunctorZero p, Functor f, Functor g) => ProfunctorZero (Biff p f g) where+  zeroProfunctor = Biff zeroProfunctor++class ProfunctorZero p => ProfunctorPlus p where+  (<+>) :: p a b -> p a b -> p a b++instance Alternative f => ProfunctorPlus (Star f) where+  Star f <+> Star g = Star (liftA2 (<|>) f g)++instance (Monad m, Alternative m) => ProfunctorPlus (Arr.Kleisli m) where+  Arr.Kleisli f <+> Arr.Kleisli g = Arr.Kleisli (liftA2 (<|>) f g)++instance Monoid r => ProfunctorPlus (Forget r) where+  Forget f <+> Forget g = Forget (liftA2 (<>) f g)++instance (Applicative f, ProfunctorPlus p) => ProfunctorPlus (Cayley f p) where+  Cayley f <+> Cayley g = Cayley (liftA2 (<+>) f g)++instance (Applicative f, ProfunctorPlus p) => ProfunctorPlus (Tannen f p) where+  Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g)++instance (ProfunctorPlus p) => ProfunctorPlus (Tambara p) where+  Tambara f <+> Tambara g = Tambara (f <+> g)++instance (ProfunctorPlus p) => ProfunctorPlus (Closure p) where+  Closure f <+> Closure g = Closure (f <+> g)++instance (ProfunctorPlus p) => ProfunctorPlus (TambaraSum p) where+  TambaraSum f <+> TambaraSum g = TambaraSum (f <+> g)++instance (ProfunctorPlus p) => ProfunctorPlus (CofreeTraversing p) where+  CofreeTraversing f <+> CofreeTraversing g = CofreeTraversing (f <+> g)++instance (ProfunctorPlus p) => ProfunctorPlus (CofreeMapping p) where+  CofreeMapping f <+> CofreeMapping g = CofreeMapping (f <+> g)++instance Alternative f => ProfunctorPlus (Joker f) where+  Joker f <+> Joker g = Joker (f <|> g)++instance Arr.ArrowPlus p => ProfunctorPlus (WrappedArrow p) where+  WrapArrow f <+> WrapArrow g = WrapArrow (f Arr.<+> g)++instance ProfunctorPlus p => ProfunctorPlus (Codensity p) where+  Codensity f <+> Codensity g = Codensity (liftA2 (<+>) f g)++instance (ProfunctorPlus p, ProfunctorPlus q) => ProfunctorPlus (Product p q) where+  Pair fl fr <+> Pair gl gr = Pair (fl <+> gl) (fr <+> gr)++instance  (Profunctor p, ProfunctorPlus q) => ProfunctorPlus (Rift p q) where+  Rift f <+> Rift g = Rift (liftA2 (<+>) f g)++instance  (ProfunctorPlus p, Functor f, Functor g) => ProfunctorPlus (Biff p f g) where+  Biff f <+> Biff g = Biff (f <+> g)++class Profunctor p => ProfunctorApply p where+  app :: p (p a b, a) b++instance Functor f => ProfunctorApply (Star f) where+  app = Star (\(Star f, a) -> f a)++instance ProfunctorApply (->) where+  app = Arr.app++instance Monad m => ProfunctorApply (Arr.Kleisli m) where+  app = Arr.app++instance ProfunctorApply (Forget r) where+  app = Forget (\(Forget f, a) -> f a)++instance (Arr.Arrow p, Arr.ArrowApply p) => ProfunctorApply (WrappedArrow p) where+  app = Arr.app++instance Alternative g => ProfunctorApply (Joker g) where+  app = Joker empty

@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase #-}+module Data.Profunctor.Cont where++-- Profunctor experiments on continuations++import Data.Profunctor+import Data.Profunctor.Rep+import Data.Profunctor.Sieve+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Class+import Data.Foldable+import Data.Traversable+import Data.Monoid+import Control.Applicative++-- ContT r m a :: (a -> m r) -> m r+-- shiftT :: ((a -> m r) -> ContT r m r) -> ContT r m a+-- shiftT :: ((a -> m r) -> (r -> m r) -> m r) -> (a -> m r) -> m r++import Data.Functor.Identity+++helper :: (a -> Bool) -> [a] -> ContT r f (Maybe a)+helper predicate xs = do+    callCC $ \cc -> do+        case find predicate xs of+          Just i -> cc (Just i)+          Nothing -> pure Nothing++helper' :: (Monad m, Monoid r) => (a -> Bool) -> [a] -> ContT r m a+helper' predicate xs = do+    shiftT $ \cc -> do+        getAp $ flip foldMap xs $ \x ->+                    Ap $ if predicate x+                            then lift (cc x)+                            else pure mempty++helper'' :: (Monad m, Monoid r) => (r -> Bool) -> [r] -> ContT r m r+helper'' predicate xs = do+    callCC $ \outer -> do+        shiftT $ \inner -> do+            foldl' (go inner outer) (pure mempty) xs+            -- getAp $ flip foldMap xs $ \x ->+            --             Ap $ if predicate x+            --                     then outer _+            --                     else lift $ inner x+  where+    go inner outer mr a +      | predicate a = mr >>= outer+      | otherwise = liftA2 (<>) mr (lift $ inner a)++stopWhen :: (Representable p, Rep p ~ f) => p (Maybe Int) r -> p [Int] r+stopWhen = withCapture (helper even)++stopWhen' :: (Monoid r, Monad m, Representable p, Rep p ~ m) => p Int r -> p [Int] r+stopWhen' = withCapture (helper' even)++stopWhen'' :: (Monad m, Representable p, Rep p ~ m) => p [a] [a] -> p [[a]] [a]+stopWhen'' = withCapture (helper'' ((>3) . length))+++-- Optic s r a r =+withCapture :: (Representable p, Rep p ~ f) => (s -> ContT r f a) -> p a r -> p s r+withCapture f p =+    tabulate $ \b ->+        let ContT g = (f b)+            handler = sieve p+         in g handler+++tester :: [[ Int ]] -> IO [Int]+tester = runStar $ stopWhen'' (Star go')+  where+    go' i = print i >> pure i+    go (Just i) = print i >> pure [i]+    go Nothing = pure []++-- class Profunctor p => Capture p where+

@@ -0,0 +1,25 @@+module Data.Profunctor.Expansive where++import Data.Profunctor+import Control.Applicative+import Data.Foldable+import Data.Tagged+import Data.Profunctor.Cayley++-- Per Reed Mullanix this is "monadicity".+-- We induce a monoid in the structure of the profunctor to collaps our argument.+-- Apparently roughly a T-algebra over some category.+class Expansive p where+  expand :: Foldable f => p a b -> p (f a) b++instance Alternative f => Expansive (Star f) where+  expand (Star f) = Star (asum . fmap f . toList)++instance Monoid r => Expansive (Forget r) where+  expand (Forget f) = Forget (foldMap f)++instance Expansive Tagged where+  expand (Tagged b) = Tagged b++instance (Functor f, Expansive p) => Expansive (Cayley f p) where+  expand (Cayley pfab) = Cayley (fmap expand pfab)

@@ -0,0 +1,22 @@+module Data.Profunctor.Extras where++import Data.Profunctor+import Data.Profunctor.Sieve+import Data.Profunctor.Strong+import Data.Profunctor.Rep+import Data.Function ((&))+import Control.Monad++join' :: (Sieve p f, Strong p) => p a (p a b) -> p a (f b)+join' = strong (&) . rmap sieve++join'' :: (Representable p, Strong p, Monad (Rep p)) => p a (p a b) -> p a b+join'' = tabulate . rmap join . sieve . strong (&) . rmap sieve++absorb :: (Representable p, m ~ Rep p, Monad m) => p a (m b) -> p a b+absorb = tabulate . fmap join . sieve++newtype Dub p f a b = Dub (p (f a) (f b))++instance (Profunctor p, Functor f) => Profunctor (Dub p f) where+  dimap f g (Dub p) = Dub (dimap (fmap f) (fmap g) p)

@@ -0,0 +1,4 @@+module Data.Profunctor.Fold where++-- Stealing ideas from https://hackage.haskell.org/package/folds+

@@ -0,0 +1,16 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+module Data.Profunctor.FoldM where+import Data.Profunctor++-- https://hackage.haskell.org/package/foldl-1.4.10/docs/Control-Foldl.html#t:FoldM+data FoldM m a b = forall x. FoldM (x -> a -> m x) (m x) (x -> m b)++instance Functor m => Profunctor (FoldM m) where+  dimap l r (FoldM step initial extract) = FoldM (\x a -> step x (l a)) initial (fmap r . extract)++-- instance Choice (FoldM m) where+--   right' (FoldM step initial extract) = FoldM (\x a -> )+--   where+--     step' x (Left l) +--     step' x (Right)

@@ -0,0 +1,16 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Data.Profunctor.Joinable where++import Data.Profunctor++class Profunctor p => Joinable p m | p -> m where+  join' :: p a (m b) -> p a b++instance Monad m => Joinable (Star m) m where+  join' (Star f) = Star (join . f)+    where+      join m = m >>= id++instance Monad m => Joinable (Forget (m r)) m where+  join' (Forget f) = Forget f

@@ -1,8 +1,17 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE ConstraintKinds #-} module Data.Profunctor.Phantom where  import Data.Profunctor import qualified Data.Functor.Contravariant as C import Data.Profunctor.Cayley++-- Once we have ImpredicativeTypes we can do this, which is nice :)+-- import Data.Void+-- type Phantom p = (forall q. C.Contravariant (p q), Profunctor p)+-- phantom :: (forall q. C.Contravariant (p q), Profunctor p) => p a x -> p a y+-- phantom = rmap absurd . C.contramap absurd  class Profunctor p => Phantom p where     phantom :: p a x -> p a y

@@ -2,6 +2,7 @@  import Data.Profunctor +-- This is just Tagged + Closed, so it doesn't add anything new. newtype Remember r a b = Remember (r -> b)   deriving Functor 

@@ -23,5 +23,6 @@ import Proton.Traversal as P import Proton.Indexed as P import Proton.Types as P+import Proton.Telescope as P  import Data.Function as P ((&))

@@ -1,5 +1,7 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE InstanceSigs #-}++{-# LANGUAGE ImpredicativeTypes #-} module Proton.Fold where  import Data.Profunctor

@@ -8,13 +8,18 @@  type Getter s t a b = forall p. Phantom p => p a b -> p s t -to :: (s -> a) -> Getter s t a b-to f = phantom . lmap f- -- Getter without Phantom requirement, may be useful with Grids/Grates-to' :: Profunctor p => (s -> a) -> Optic p s b a b-to' f = lmap f+to :: Profunctor p => (s -> a) -> Optic p s b a b+to f = lmap f +-- Getter based on Phantom+to' :: (s -> a) -> Getter s t a b+to' f = phantom . lmap f++-- Getter based on Forget explicitly+to'' :: (s -> a) -> Optic (Forget r) s t a b+to'' f (Forget g) = Forget (g . f)+ view :: Optic (Forget a) s t a b -> s -> a view g = runForget . g $ Forget id @@ -22,7 +27,7 @@ views g f = f . view g  like :: a -> Getter s t a b-like = to . const+like = to' . const  infixl 8 ^. (^.) ::  s -> Optic (Forget a) s t a b -> a

@@ -0,0 +1,10 @@+module Proton.Par where++import Proton.Types+import Data.Profunctor.Joinable+import Control.Concurrent.Async+import Data.Profunctor++-- parrallelising :: Optic p s t a (m b) ??+parrallelising :: Joinable p Concurrently => p a (IO b) -> p a b+parrallelising  = join' . rmap Concurrently

@@ -1,7 +1,6 @@ module Proton.Prisms where  import Data.Profunctor-import Proton.Types import Data.Market  type Prism s t a b = forall p. Choice p => p a b -> p s t

@@ -28,7 +28,7 @@ reviews r f = f . review r  re :: (Tagged a b -> Tagged s t) -> Getter b a t s-re r = to (review r)+re r = to' (review r)  unto :: forall (s :: *) t (a :: *) b. (b -> t) -> (Tagged a b -> Tagged s t) unto f = rmap f . retagged

@@ -0,0 +1,8 @@+module Proton.Telescope where++import Proton.Types+import Data.Profunctor.Expansive++-- Foldy optic for expanding structure.+cat :: Expansive p => Optic p [a] b a b+cat = expand

@@ -30,6 +30,10 @@ traverseOf :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t traverseOf t = runStar . t . Star +infixr 4 %%~+(%%~) :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t+(%%~) = traverseOf+ beside :: forall s t a b s' t' p r. (Representable p, Bitraversable r, Applicative (Rep p)) => Optic p s t a b -> Optic p s' t' a b -> Optic p (r s s') (r t t') a b beside t1 t2 p = tabulate go   where