packages feed

proton 0.0.3 → 0.0.4

raw patch · 14 files changed

+339/−69 lines, 14 files

Files

proton.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 2ae23bade3f5327fbc45a47352e8f6e4bba83f9416235c877fa895c0608f1b6e+-- hash: 6c4266df82126ebafb6c7362d66666f46888c5985cd3ee051d5a1605103d1812  name:           proton-version:        0.0.3+version:        0.0.4 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@@ -47,14 +47,24 @@       Data.Profunctor.Indexed       Data.Profunctor.Joinable       Data.Profunctor.MStrong+      Data.Profunctor.NonLinear       Data.Profunctor.Phantom+      Data.Profunctor.Reader+      Data.Profunctor.Reader.Class       Data.Profunctor.Reflector       Data.Profunctor.Remember+      Data.Profunctor.State+      Data.Profunctor.State.Class+      Data.Profunctor.Traced+      Data.Profunctor.Utils       Data.Profunctor.Withering+      Data.Profunctor.Writer+      Data.Profunctor.Writer.Class       Examples.Algebraic       Examples.Alt       Examples.Coalgebraic       Examples.Diffract+      Examples.DSP       Examples.Flowers       Examples.Glass       Examples.Layers@@ -94,7 +104,7 @@       Paths_proton   hs-source-dirs:       src-  default-extensions: FlexibleInstances FlexibleContexts ScopedTypeVariables LambdaCase ViewPatterns TypeApplications TypeOperators DeriveFunctor DeriveTraversable DeriveGeneric DerivingStrategies StandaloneDeriving TemplateHaskell RankNTypes TypeFamilies InstanceSigs+  default-extensions: FlexibleInstances MultiParamTypeClasses FlexibleContexts ScopedTypeVariables LambdaCase ViewPatterns TypeApplications TypeOperators DeriveFunctor DeriveTraversable DeriveGeneric DerivingStrategies StandaloneDeriving TemplateHaskell RankNTypes TypeFamilies InstanceSigs   ghc-options: -Wall   build-depends:       adjunctions
src/Data/Profunctor/Arrow.hs view
@@ -34,19 +34,19 @@  -- | Precomposition with a pure function. (^>>) :: (Profunctor p, C.Category p) => (b -> c) -> p c d -> p b d-f ^>> p = arr f C.>>> p+f ^>> p = lmap f 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+p >>^ f = rmap f p  -- | 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+p <<^ f = lmap f p  -- | 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+f ^<< p = rmap f 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
src/Data/Profunctor/Cont.hs view
@@ -1,79 +1,141 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BlockArguments #-} 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+import Data.Profunctor.Arrow+import Data.Function+import qualified Control.Category as C+import Control.Category ((>>>))+import Data.Void --- 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+data ContP r a b =+    ContP {runContP :: a -> ((b -> r) -> r) }+    deriving Functor -import Data.Functor.Identity+instance C.Category (ContP r) where+ id = ContP (&)+ ContP bCrR . ContP aBrR = ContP $ \a cr ->+     aBrR a $ \b -> bCrR b cr +instance Profunctor (ContP r) where+  dimap l r (ContP f) = fmap r $ ContP (\a cr -> f (l a) cr) -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+instance ProfunctorApply (ContP r) where+  app = ContP \(ContP aBrR, a) br -> aBrR a br -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+class Profunctor p => ProfunctorCont p where+  -- callCC :: (p a b -> p x a) -> p x a+  -- callCC :: (p a x -> p a (Either x b)) -> p a b+  -- callCC :: (p (Either a a) x -> p a x) -> p a a+  -- callCC :: (p (Either b x) x -> p a b) -> p a b+  -- callCC :: (p b x -> p a b) -> p a b+  -- callCC :: p ((a -> p q b) -> p q a, q) a+  callCC :: (p a b -> p x a) -> p x a -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)+instance Choice (ContP r) where+  right' (ContP f) = ContP $ \eCA eCBR ->+      case eCA of+          Left c -> eCBR (Left c)+          Right a -> f a (eCBR . Right) -stopWhen :: (Representable p, Rep p ~ f) => p (Maybe Int) r -> p [Int] r-stopWhen = withCapture (helper even)+instance Strong (ContP r) where+  first' (ContP aBrR) = ContP \(a, c) bcr -> aBrR a (bcr . (,c)) -stopWhen' :: (Monoid r, Monad m, Representable p, Rep p ~ m) => p Int r -> p [Int] r-stopWhen' = withCapture (helper' even)+instance ProfunctorCont (ContP r) where+  callCC f = ContP \q ar ->+    let ContP x = f $ ContP \a _ -> ar a+     in x q ar -stopWhen'' :: (Monad m, Representable p, Rep p ~ m) => p [a] [a] -> p [[a]] [a]-stopWhen'' = withCapture (helper'' ((>3) . length))+evalContP :: ContP r a r -> a -> r+evalContP (ContP f) a = f a id +reset :: ContP r a r -> ContP r' a r+reset  = arr . evalContP --- 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+shift :: ContP r (ContP r (a -> r) r) a+shift = ContP (evalContP) +neutralize :: ContP r r x+neutralize = ContP (\r _ -> r) -tester :: [[ Int ]] -> IO [Int]-tester = runStar $ stopWhen'' (Star go')+testP :: ContP String Int Int -- ContP String Int Int+testP = catcher >>> arr succ >>>  arr succ >>> arr succ   where-    go' i = print i >> pure i-    go (Just i) = print i >> pure [i]-    go Nothing = pure []+    catcher :: ContP String Int Int+    catcher = dimap (\n -> if even n then Right n else Left n) (either absurd id) (lmap show neutralize +++ C.id) --- class Profunctor p => Capture p where+testP'' :: ContP String Int Int+testP'' = callCC \cc ->+    catcher cc >>> arr succ >>> arr succ >>> arr succ+  where+    catcher :: ContP String Int Int -> ContP String Int Int+    catcher p = dimap (splitPred even) unify (p +++ C.id)++splitPred :: (a -> Bool) -> a -> Either a a+splitPred predicate a = (if predicate a then Right a else Left a)++unify :: Either a a -> a+unify = either id id+++-- 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
src/Data/Profunctor/MStrong.hs view
@@ -5,6 +5,7 @@ import Data.Profunctor import Data.Tagged import Data.Tuple+import Data.Foldable  class Profunctor p => MStrong p where   mfirst' ::  Monoid m => p a b -> p (a, m) (b, m)@@ -26,8 +27,5 @@ instance MStrong Tagged where   msecond' (Tagged b) = Tagged (mempty, b) -instance Traversable f => MStrong (Costar f) where-  msecond' (Costar f) = Costar go-    where-      go fma = f <$> sequenceA fma-+instance (Functor f, Foldable f) => MStrong (Costar f) where+  msecond' (Costar f) = Costar (\fma -> (fold (fmap fst fma), f (fmap snd fma)))
+ src/Data/Profunctor/NonLinear.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE UndecidableInstances #-}+module Data.Profunctor.NonLinear where++import Data.Profunctor++-- A Class for providing explicit duplication support for arrow-likes +-- that don't support Dimap using (->)+class NonLinear p where+  dup :: p a b -> p a (b, b)++-- An overlappable instance for all profunctors.+-- This should be overridden if nonlinearity has special meaning in your domain+instance {-# OVERLAPPABLE #-} Profunctor p => NonLinear p where+  dup = rmap (\a -> (a, a))
+ src/Data/Profunctor/Reader.hs view
@@ -0,0 +1,26 @@+module Data.Profunctor.Reader where++import Data.Profunctor+import Control.Category (Category)+import qualified Control.Category as C+import Data.Bifunctor (first, second)+import Data.Profunctor.Reader.Class+import Data.Profunctor.Strong++newtype ReaderT r p a b = ReaderT (p (a, r) b)++instance Profunctor p => Profunctor (ReaderT r p) where+  dimap f g (ReaderT r) = ReaderT (dimap (first f) (g) r)++instance (Category p, Strong p) => Category (ReaderT r p) where+  id = ReaderT (lmap fst C.id)+  ReaderT x . ReaderT y = ReaderT (x C.. strong (\(_, r) b -> (b, r)) y)++instance (Profunctor p, Category p) => ProfunctorReader r (ReaderT r p) where+  ask = ReaderT C.id+  reader f = rmap (uncurry $ flip f) ask+  local f (ReaderT q) = ReaderT (lmap (second f) q)++instance (Profunctor p) => ProfunctorReader' r (ReaderT r p) where+  ask' (ReaderT p) = ReaderT $ lmap (\(a, r) -> ((a, r), r)) p+  local' f (ReaderT p) = ReaderT $ lmap (second f) p
+ src/Data/Profunctor/Reader/Class.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+module Data.Profunctor.Reader.Class where++import Data.Profunctor++class (Profunctor p) => ProfunctorReader r p | p -> r where+  {-# MINIMAL (ask | reader), local #-}+  ask :: p a (a, r)+  ask = reader (flip (,))+  reader :: (r -> a -> b) -> p a b+  reader f = rmap (uncurry (flip f)) ask+  local :: (r -> r) -> p a b -> p a b++class (Profunctor p) => ProfunctorReader' r p | p -> r where+  {-# MINIMAL ask', local' #-}+  ask' :: p (a, r) b -> p a b+  local' :: (r -> r) -> p a b -> p a b
+ src/Data/Profunctor/State.hs view
@@ -0,0 +1,23 @@+module Data.Profunctor.State where++import Data.Profunctor+import Control.Category (Category)+import qualified Control.Category as C+import Data.Bifunctor (first)+import Data.Profunctor.State.Class++newtype StateT s p a b = StateT (p (a, s) (b, s))++instance Profunctor p => Profunctor (StateT s p) where+  dimap f g (StateT s) = StateT (dimap (first f) (first g) s)++instance (Category p) => Category (StateT s p) where+  id = StateT C.id+  StateT s . StateT t = StateT (s C.. t)++instance (Category p, Profunctor p) => ProfunctorState s (StateT s p) where+  state (StateT p) = StateT (dimap (\(a, s) -> ((a, s), s)) fst p)++instance (Profunctor p) => ProfunctorState' s (StateT s p) where+  get' (StateT p) = StateT (lmap (\(a, s) -> ((a, s), s)) p)+  put' (StateT p) = StateT (rmap fst p)
+ src/Data/Profunctor/State/Class.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE FunctionalDependencies #-}+module Data.Profunctor.State.Class where++import Data.Profunctor+import Control.Category ((>>>))+import qualified Control.Category as C++class (C.Category p, Profunctor p) => ProfunctorState s p | p -> s where+  {-# MINIMAL state | (get, put) #-}+  get :: p a (a, s)+  get = state (rmap (\(a, s) -> ((a, s), s)) C.id)+  put :: p (a, s) a+  put = state (lmap (\((a, s), _) -> (a, s)) C.id)+  state :: p (a, s) (b, s) -> p a b+  state p = (get >>> p >>> put)+++class (Profunctor p) => ProfunctorState' s p | p -> s where+  {-# MINIMAL (get', put') #-}+  get' :: p (a, s) b -> p a b+  put' :: p a (b, s) -> p a b
+ src/Data/Profunctor/Traced.hs view
@@ -0,0 +1,28 @@+module Data.Profunctor.Traced where++import Data.Profunctor+import Data.Bifunctor (first)++data Traced m a b = Traced ((a, m) -> b)++instance Profunctor (Traced m) where+  dimap f g (Traced t) = Traced (g . t . first f)++instance Strong (Traced m) where+  first' (Traced t) = Traced (first' t . reassoc)+    where+      reassoc ((a, c), m) = ((a, m), c)++instance Choice (Traced m) where+  left' (Traced t) = Traced (left' t . reassoc)+    where+      reassoc (Left a, m) = Left (a, m)+      reassoc (Right c, _) = Right c++extractTraced :: Monoid m => Traced m a b -> a -> b+extractTraced (Traced t) a = t (a, mempty)++-- extend :: Semigroup m => (Traced m x a -> b) -> Traced m x a -> Traced m x b+-- extend f (Traced t) = Traced go+--   where+--     go (x, m) = f $ Traced (\(x, m') -> t (x, m <> m'))
+ src/Data/Profunctor/Utils.hs view
@@ -0,0 +1,13 @@+module Data.Profunctor.Utils where++import Data.Profunctor+import Data.Profunctor.NonLinear+import Control.Category ((>>>), Category)+++class Branch p where+  branch :: p a b -> p b Bool -> p a (Either b b)++choose :: (Category p, Branch p, NonLinear p, Strong p) => p b Bool -> p a b -> p a (Either b b)+choose predicate p = branch p predicate+
+ src/Data/Profunctor/Writer.hs view
@@ -0,0 +1,21 @@+module Data.Profunctor.Writer where++import Data.Profunctor+import Control.Category (Category)+import qualified Control.Category as C+import Data.Bifunctor (first)+import Data.Profunctor.Writer.Class++newtype WriterT w p a b = WriterT (p a (b, w))++instance Profunctor p => Profunctor (WriterT w p) where+  dimap f g (WriterT w) = WriterT (dimap f (first g) w)++instance (Monoid w, Category p, Strong p) => Category (WriterT w p) where+  id = WriterT (rmap (\b -> (b, mempty)) C.id)+  WriterT x . WriterT y = WriterT (rmap (\((c, w), w') -> (c, w <> w')) (first' x) C.. y)++instance (Profunctor p, Monoid w) => ProfunctorWriter' w (WriterT w p) where+  tell' (WriterT p) = WriterT (rmap (\((b, w), w') -> (b, w <> w')) p)+  listen' (WriterT p) = WriterT (rmap (\(b, w) -> ((b, w), w)) p)+  pass' (WriterT p) = WriterT (rmap (\((b, f), w) -> (b, f w)) p)
+ src/Data/Profunctor/Writer/Class.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FunctionalDependencies #-}+module Data.Profunctor.Writer.Class where++import Data.Profunctor+import qualified Control.Category as C+import Data.Bifunctor (second)++class (Monoid w, C.Category p, Profunctor p) => ProfunctorWriter w p | p -> w where+  {-# MINIMAL listen, pass #-}+  tell :: p (a, w) a+  tell = lmap (second (\w -> (<> w))) pass+  listen :: p a (a, w)+  pass :: p (a, w -> w) a++class (Monoid w, Profunctor p) => ProfunctorWriter' w p | p -> w where+  {-# MINIMAL listen', pass' #-}+  tell' :: p a (b, w) -> p a b+  tell' p = pass' (rmap (\(b, w) -> (b, (<> w))) p)+  listen' :: p a b -> p a (b, w)+  pass' :: p a (b, w -> w) -> p a b
+ src/Examples/DSP.hs view
@@ -0,0 +1,14 @@+module Examples.DSP where++import Data.Profunctor+import Data.Profunctor.Rep++blur :: Costar ((->) Int) Int Float+blur = cotabulate go+  where+    go :: (Int -> Int) -> Float+    go f = fromIntegral (f (-1) + f 0 + f 1) / 3+++-- sample :: Monoid e => Costar ((->) e) a b -> e -> (e -> a) -> b+-- sample (Costar f) = f