packages feed

proton (empty) → 0.0.1

raw patch · 57 files changed

+2142/−0 lines, 57 filesdep +adjunctionsdep +basedep +bifunctorssetup-changed

Dependencies added: adjunctions, base, bifunctors, comonad, compactable, containers, contravariant, distributive, linear, mtl, profunctors, tagged

Files

+ ChangeLog.md view
@@ -0,0 +1,6 @@+# Changelog for proton++### 0.0.1+- Initial release++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Chris Penner (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Chris Penner nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,28 @@+# proton - Profunctor optics++An **extremely experimental** implementation of profunctor optics in Haskell. +This mostly exists so I have a place to experiment with new ideas and new optics. Most things should work but I offer no performance guarantees.++Not intended for use in production (yet).++Includes:++* Lenses+* Prisms+* Folds+* Traversals+* Getters+* Reviews+* Setters+* Isos+* Algebraic lenses+* Coalgebraic prisms+* Achromatic lenses+* Grids+* Grates+* Glass+* Loops+* Feedbacks+* Kaleidoscopes++And always growing!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ proton.cabal view
@@ -0,0 +1,101 @@+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: de218e5a99e5d137be7685d7249aafd9d954cdc83f2bcdd1366a114fe7791ff2++name:           proton+version:        0.0.1+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+author:         Chris Penner+maintainer:     christopher.penner@gmail.com+copyright:      Chris Penner+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/ChrisPenner/proton++library+  exposed-modules:+      Data.Market+      Data.Pair+      Data.Profunctor.Annotated+      Data.Profunctor.Coindexed+      Data.Profunctor.Depending+      Data.Profunctor.Distributing+      Data.Profunctor.DoubleStar+      Data.Profunctor.Expanding+      Data.Profunctor.Extraction+      Data.Profunctor.Indexed+      Data.Profunctor.MStrong+      Data.Profunctor.Phantom+      Data.Profunctor.Reflector+      Data.Profunctor.Remember+      Data.Profunctor.Withering+      Examples.Algebraic+      Examples.Alt+      Examples.Coalgebraic+      Examples.Diffract+      Examples.Flowers+      Examples.Glass+      Examples.Layers+      Examples.Loop+      Examples.Scrap+      Proton+      Proton.Achromatic+      Proton.Algebraic+      Proton.Annotated+      Proton.Coalgebraic+      Proton.Coindexed+      Proton.Diffraction+      Proton.Feedback+      Proton.Fold+      Proton.Getter+      Proton.Glass+      Proton.Grate+      Proton.Grid+      Proton.Indexed+      Proton.Internal.Orphans+      Proton.Iso+      Proton.Kaleidoscope+      Proton.Lens+      Proton.Loop+      Proton.Miso+      Proton.Plated+      Proton.PreGrate+      Proton.Prisms+      Proton.Review+      Proton.Setter+      Proton.Traversal+      Proton.Types+      Proton.Wither+  other-modules:+      Paths_proton+  hs-source-dirs:+      src+  default-extensions: FlexibleInstances FlexibleContexts ScopedTypeVariables LambdaCase ViewPatterns TypeApplications TypeOperators DeriveFunctor DeriveTraversable DeriveGeneric DerivingStrategies StandaloneDeriving TemplateHaskell RankNTypes TypeFamilies InstanceSigs+  ghc-options: -Wall+  build-depends:+      adjunctions+    , base >=4.7 && <5+    , bifunctors+    , comonad+    , compactable+    , containers+    , contravariant+    , distributive+    , linear+    , mtl+    , profunctors >=5.5.1+    , tagged+  default-language: Haskell2010
+ src/Data/Market.hs view
@@ -0,0 +1,19 @@+module Data.Market where++import Data.Profunctor+import Data.Bifunctor++-- | The `Market` profunctor characterizes a `Prism`.+data Market a b s t = Market (b -> t) (s -> Either t a)++instance Functor (Market a b s) where+  fmap f (Market proj match) = Market (f . proj) (first f . match)++instance Profunctor (Market a b) where+  dimap f g (Market a b) = Market (g . a) (first g . b . f)++instance Choice (Market a b) where+  left' (Market x y) =+    Market (Left . x) (either (first Left . y) (Left . Right))+  right' (Market x y) =+    Market (Right . x) (either (Left . Left) (first Right . y))
+ src/Data/Pair.hs view
@@ -0,0 +1,27 @@+module Data.Pair where++import Data.Functor.Rep+import Data.Distributive+import Data.Profunctor++data Pair a = Pair a a+  deriving (Show, Eq, Ord, Functor)++instance Applicative Pair where+  pure a = Pair a a+  Pair f f' <*> Pair a a' = Pair (f a) (f' a')++instance Distributive Pair where+  distribute = distributeRep++instance Representable Pair where+  type Rep Pair = Bool+  tabulate f = Pair (f False) (f True)+  index (Pair a _) False = a+  index (Pair _ b) True = b++paired :: Profunctor p => p (Pair a) (Pair b) -> p (a, a) (b, b)+paired = dimap (\(a, a') -> Pair a a') (\(Pair a a') -> (a, a'))++liftPair :: (a -> a -> b) -> Pair a -> b+liftPair f (Pair a a') = f a a'
+ src/Data/Profunctor/Annotated.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DefaultSignatures #-}+module Data.Profunctor.Annotated where++import Data.Profunctor+import Data.Tagged++class (Profunctor p, Profunctor q) => Annotatable e p q | q -> p where+    coindexed :: p a (e, b) -> q a b+    default coindexed :: (p ~ q) => p a (e, b) -> q a b+    coindexed = rmap snd++data Annotated e p a b = Annotated {runCoindexed :: (p a (e, b))}++instance Profunctor p => Profunctor (Annotated e p) where+  dimap f g (Annotated p) = Annotated (dimap f (second' g) p)++instance Strong p => Strong (Annotated i p) where+  second' (Annotated p) = Annotated (dimap id reassoc $ second' p)+    where+      reassoc (c, (i, b)) = (i, (c, b))++instance Profunctor p => Annotatable i p (Annotated i p) where+  coindexed p = Annotated p++instance Annotatable e (Forget r) (Forget r) where+  coindexed (Forget f) = (Forget f)++instance Annotatable e (->) (->) where+instance Functor f => Annotatable e (Star f) (Star f) where+instance Functor f => Annotatable e (Costar f) (Costar f) where+instance Annotatable e Tagged Tagged where
+ src/Data/Profunctor/Coindexed.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DefaultSignatures #-}+module Data.Profunctor.Coindexed where++import Data.Profunctor+import Data.Void+import Control.Applicative+import Control.Monad+import Data.Tagged++class (Profunctor p, Profunctor q) => Coindexable e p q | q -> p where+    coindexed :: p a (Either e b) -> q a b+    default coindexed :: (e ~ Void, p ~ q) => p a (Either e b) -> q a b+    coindexed = rmap (either absurd id)++data Coindexed e p a b = Coindexed {runCoindexed :: (p a (Either e b))}++instance Profunctor p => Profunctor (Coindexed e p) where+  dimap f g (Coindexed p) = Coindexed (dimap f (right' g) p)++instance Choice p => Choice (Coindexed i p) where+  right' (Coindexed p) = Coindexed (dimap id reassoc $ right' p)+    where+      reassoc (Left c) = Right (Left c)+      reassoc (Right (Left i)) = Left i+      reassoc (Right (Right b)) = Right (Right b)++instance Profunctor p => Coindexable i p (Coindexed i p) where+  coindexed p = Coindexed p++instance Coindexable e (Forget r) (Forget r) where+  coindexed (Forget f) = (Forget f)++instance Coindexable Void (->) (->)++instance {-# OVERLAPPING #-} Functor f => Coindexable Void (Star f) (Star f) where+-- Could use selective applicative here instead.+instance (Alternative f, Monad f) => Coindexable e (Star f) (Star f) where+  coindexed (Star f) = Star $ f >=> either (const empty) pure+instance Functor f => Coindexable Void (Costar f) (Costar f) where+instance Coindexable Void Tagged Tagged where
+ src/Data/Profunctor/Depending.hs view
@@ -0,0 +1,10 @@+module Data.Profunctor.Depending where++import Data.Profunctor+import Data.Profunctor.Traversing++class Traversing p => Depending p where+  depend :: (forall f. Monad f => (a -> f b) -> (s -> f t)) -> p a b -> p s t++instance Monad f => Depending (Star f) where+  depend f (Star amb) = Star (f amb)
+ src/Data/Profunctor/Distributing.hs view
@@ -0,0 +1,7 @@+module Data.Profunctor.Distributing where++import Data.Profunctor+import Data.Functor.Rep++distribute' :: (Closed p, Representable g) => p a b -> p (g a) (g b)+distribute' = dimap index tabulate . closed
+ src/Data/Profunctor/DoubleStar.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE InstanceSigs #-}+module Data.Profunctor.DoubleStar where++import Data.Profunctor+import Data.Profunctor.Traversing+import Data.Profunctor.MStrong+import Data.Distributive++data DoubleStar f g a b = DoubleStar (f a -> g b)++instance (Functor f, Functor g) => Profunctor (DoubleStar f g) where+  dimap l r (DoubleStar p) = DoubleStar (dimap (fmap l) (fmap r) p)++instance (Traversable f, Distributive g) => MStrong (DoubleStar f g) where+  msecond' :: forall m a b. Monoid m => DoubleStar f g a b -> DoubleStar f g (m, a) (m, b)+  msecond' (DoubleStar p) = DoubleStar (go p)+    where+      go :: (f a -> g b) -> f (m, a) -> g (m, b)+      go f fam = distribute . fmap f . sequenceA $ fam+++instance (Traversable f, Distributive g) => Choice (DoubleStar f g) where+  right' :: forall c a b. DoubleStar f g a b -> DoubleStar f g (Either c a) (Either c b)+  right' (DoubleStar p) = DoubleStar go+    where+      go :: f (Either c a) -> g (Either c b)+      go = distribute . fmap p . sequenceA++-- instance (Functor f, Applicative g) => Traversing (DoubleStar f g) where+--   -- traverse' :: Traversable t => p a b -> p (t a) (t b)+--   -- traverse' (DoubleStar p) = DoubleStar (traverse m)+--   wander :: forall s t a b h. Applicative h =>( (a -> h b) -> s -> h t) -> DoubleStar f g a b -> DoubleStar f g s t+--   wander f (DoubleStar p) = DoubleStar go+--     where+--       go :: f s -> g t+--       go fs = _ . fmap (f _p') $ fs+
+ src/Data/Profunctor/Expanding.hs view
@@ -0,0 +1,28 @@+module Data.Profunctor.Expanding where++import Data.Profunctor+import Control.Comonad++class Profunctor p => Expanding p where+  expand :: Comonad w => p (w a) b -> p a (w b)+  -- expand :: Applicative f => p (f a) (f b) -> p a b++-- instance Expanding (->) where+--   expand f = _ f++-- instance Expanding (Forget r) where+--   expand (Forget rToA) = Forget (rToA . pure)++-- instance Expanding (Forget r) where+--   expand (Forget rToA) = Forget (_ rToA)+++-- instance Functor g => Expanding (Star g) where+--   expand (Star f) = Star (_ f)++-- instance Functor g => Expanding (Costar g) where+--   expand (Costar f) = Costar (_ f)+++-- extending :: (Comonad w) => Optic (Costar w) a (w b) a b+-- extending (Costar f) = Costar (extend f)
+ src/Data/Profunctor/Extraction.hs view
@@ -0,0 +1,62 @@+module Data.Profunctor.Extraction where++import Data.Profunctor+import Control.Comonad+import Data.Distributive+import qualified Data.List.NonEmpty as NE+import Control.Comonad.Store+import Data.Pair++class Profunctor p => Extraction p where+  extractions :: Comonad w => p (w a) b -> p (w a) (w b)++instance Extraction (Forget r) where+  extractions (Forget f) = Forget f++instance Extraction (->) where+  extractions f = extend f++instance Distributive f => Extraction (Star f) where+  extractions (Star f) = Star (distribute . extend f)++act :: (Star f a b -> Star f s t) -> (a -> f b) -> s -> f t+act o f = runStar (o (Star f))++t :: (NE.NonEmpty a) -> Pair (Maybe a)+t (a NE.:| (b : _)) = Pair (Just a) (Just b)+t (a NE.:| _) = Pair (Just a) Nothing++u :: (NE.NonEmpty Int) -> Pair Int+u xs = Pair (sum xs) (NE.length xs)+++++-- thingy :: forall w a b. Comonad w => (a -> w (Either a b)) -> (w a -> w b)+-- thingy f = extend loop . fmap Left+--     where+--       loop :: w (Either a b) -> b+--       loop w = case extract w of+--           Left a' -> loop $ f a'+--           Right b -> b++home :: Int -> Store Int Int -> Either Int Int+home n s | extract s == n = Left $ pos s+  | abs (peeks (+1) s - n) < abs (peeks (subtract 1) s - n) = Right $ peeks (+1) s+  | otherwise = Right $ peeks (subtract 1) s++looper :: NE.NonEmpty Int -> Either [Int] Int+looper xs | sum xs > 10 = Left (NE.toList xs)+  | otherwise = Right $ (sum xs + 1)++coiterate :: forall w a b.+         (Traversable w, Comonad w)+         => (w a -> Either b a)+         -> (w a -> w b)+coiterate f = extend loop+    where+      loop :: w a -> b+      loop = either id loop . sequenceA . extend f++-- thingy :: (Choice p, Cochoice p) => p a (Either b a) -> p (w a) (w b)+-- thingy = _ . unright . _ . right'
+ src/Data/Profunctor/Indexed.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DefaultSignatures #-}+module Data.Profunctor.Indexed where++import Data.Profunctor+import Data.Profunctor.Traversing+import Data.Tagged++class (Profunctor p, Profunctor q) => Indexable i p q | p -> q where+    indexed :: p a b -> q (i, a) b+    default indexed :: (p ~ q) => p a b -> q (i, a) b+    indexed = lmap snd++-- closeIndex :: (Closed q, Indexable i p q) => p a b -> q a (i -> b)+-- closeIndex = lmap (flip (,)) . closed  . indexed++data Indexed i p a b = Indexed (p (i, a) b)+newtype UnIndexed i p a b = UnIndexed (p a b)+  deriving newtype (Profunctor, Closed, Strong, Choice, Traversing, Cochoice, Costrong)++instance Profunctor p => Profunctor (Indexed i p) where+  dimap f g (Indexed p) = Indexed (dimap (second' f) g p)++instance Strong p => Strong (Indexed i p) where+  second' (Indexed p) = Indexed (dimap reassoc id $ second' p)+    where+      reassoc (i, (c, a)) = (c, (i, a))++instance Profunctor p => Indexable i (Indexed i p) p where+  indexed (Indexed p) = p++instance Profunctor p => Indexable i (UnIndexed i p) p where+  indexed (UnIndexed p) = lmap snd p++instance Indexable i (Forget r) (Forget r) where+instance Functor f => Indexable i (Star f) (Star f) where+instance Functor f => Indexable i (Costar f) (Costar f) where+instance Indexable i (->) (->) where+instance Indexable i Tagged Tagged where
+ src/Data/Profunctor/MStrong.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Data.Profunctor.MStrong where++import Data.Profunctor+import Data.Tagged+import Data.Tuple++class Profunctor p => MStrong p where+  mfirst' ::  Monoid m => p a b -> p (a, m) (b, m)+  mfirst' = dimap swap swap . msecond'+  msecond' ::  Monoid m => p a b -> p (m, a) (m, b)+  msecond' = dimap swap swap . mfirst'++  {-# MINIMAL mfirst' | msecond' #-}++instance MStrong (Forget r) where+  msecond' = second'++instance MStrong (->) where+  msecond' = second'++instance Functor f => MStrong (Star f) where+  msecond'  = second'++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+
+ src/Data/Profunctor/Phantom.hs view
@@ -0,0 +1,17 @@+module Data.Profunctor.Phantom where++import Data.Profunctor+import qualified Data.Functor.Contravariant as C+import Data.Profunctor.Cayley++class Profunctor p => Phantom p where+    phantom :: p a x -> p a y++instance Phantom (Forget r) where+  phantom (Forget f) = Forget f++instance (Functor f, C.Contravariant f) => Phantom (Star f) where+  phantom (Star f) = Star (C.phantom . f)++instance (Functor f, Phantom p) => Phantom (Cayley f p) where+  phantom (Cayley fpab) = Cayley (fmap phantom fpab)
+ src/Data/Profunctor/Reflector.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Profunctor.Reflector where++import Data.Tagged++import Data.Profunctor+import Data.Profunctor.MStrong+import Data.Distributive++class MStrong p => Reflector p where+  reflected :: Applicative f => p a b -> p (f a) (f b)++instance Reflector (->) where+  reflected = fmap++instance Traversable f => Reflector (Costar f) where+  reflected (Costar f) = Costar (fmap f . sequenceA)++instance Reflector Tagged where+  reflected (Tagged b) = Tagged (pure b)++instance Distributive f => Reflector (Star f) where+  reflected (Star f) = Star (collect f)++-- instance (MStrong p, Corepresentable p, Traversable f, Corep p ~ f) => Reflector p where+--   reflected p = cotabulate . go $ cosieve p+--     where+--       go :: forall g a b. Applicative g => (f a -> b) -> f (g a) -> (g b)+--       go f fga = f <$> sequenceA fga
+ src/Data/Profunctor/Remember.hs view
@@ -0,0 +1,18 @@+module Data.Profunctor.Remember where++import Data.Profunctor++newtype Remember r a b = Remember (r -> b)+  deriving Functor++instance Profunctor (Remember r) where+  dimap _ g (Remember x) = Remember (g . x)++instance Choice (Remember r) where+  left' (Remember x) = Remember (Left . x)++instance Closed (Remember r) where+  closed (Remember x) = Remember (\r _ -> x r)++instance Costrong (Remember r) where+  unfirst (Remember x) = Remember (fst . x)
+ src/Data/Profunctor/Withering.hs view
@@ -0,0 +1,40 @@+module Data.Profunctor.Withering where++import Data.Profunctor+import Data.Profunctor.Traversing+import Control.Applicative++class (Traversing p) => Withering p where+  cull :: (forall f. Alternative f => (a -> f b) -> (s -> f t)) -> p a b -> p s t++instance Alternative f => Withering (Star f) where+  cull f (Star amb) = Star (f amb)++instance Monoid m => Withering (Forget m) where+  cull f (Forget h) = Forget (getAnnihilation . f (AltConst . Just . h))+    where+      getAnnihilation (AltConst Nothing) = mempty+      getAnnihilation (AltConst (Just m)) = m++newtype AltConst a b = AltConst (Maybe a)+  deriving stock (Eq, Ord, Show, Functor)++instance Monoid a => Applicative (AltConst a) where+  pure _ = (AltConst (Just mempty))+  (AltConst Nothing) <*> _ = (AltConst Nothing)+  _ <*> (AltConst Nothing) = (AltConst Nothing)+  (AltConst (Just a)) <*> (AltConst (Just b)) = AltConst (Just (a <> b))++instance (Semigroup a) => Semigroup (AltConst a x) where+  (AltConst Nothing) <> _ = (AltConst Nothing)+  _ <> (AltConst Nothing) = (AltConst Nothing)+  (AltConst (Just a)) <> (AltConst (Just b)) = AltConst (Just (a <> b))++instance (Monoid a) => Monoid (AltConst a x) where+  mempty = (AltConst (Just mempty))++instance Monoid m => Alternative (AltConst m) where+  empty = (AltConst Nothing)+  (AltConst Nothing) <|> a = a+  a <|> (AltConst Nothing) = a+  (AltConst (Just a)) <|> (AltConst (Just b)) = (AltConst (Just (a <> b)))
+ src/Examples/Algebraic.hs view
@@ -0,0 +1,29 @@+module Examples.Algebraic where++import Proton++pad :: AlgebraicLens String [String] String Int+pad = listLens id padder+  where+    padder :: [String] -> Int -> [String]+    padder xs n = fmap (\s -> take n $ s <> repeat ' ') xs++padLength :: AlgebraicLens String [String] Int Int+padLength = listLens length padder+  where+    padder :: [String] -> Int -> [String]+    padder xs n = fmap (\s -> take n $ s <> repeat ' ') xs++-- >>> ["a", "hello", "yo"] & padLength >- maximum+-- ["a    ","hello","yo   "]+-- >>> ["a", "hello", "yo"] & padLength >- minimum+-- ["a","h","y"]++-- >>> ["a", "hello", "yo"] & pad ?. 6+-- ["a     ","hello ","yo    "]+-- >>> ["a", "hello", "yo"] & pad ?. 2+-- ["a ","he","yo"]+-- >>> ["a", "hello", "yo"] & pad >- maximum . fmap length+-- ["a    ","hello","yo   "]+-- >>> ["a", "hello", "yo"] & pad >- minimum . fmap length+-- ["a","h","y"]
+ src/Examples/Alt.hs view
@@ -0,0 +1,13 @@+module Examples.Alt where++-- import Proton+-- import Debug.Trace+-- import Data.Functor.Identity+-- import Data.Foldable+-- import Linear++-- test = [Just (1 :: Int), Nothing, Just 3] & collapse *% sum+-- test = [Nothing, Just 2] & collapse *% (*100) . sum+-- test = (V3 (Just 1) (Just 2) (Just 3)) &  convolving *% (*100) . sum++    -- print $ Measurements [5, 4, 3, 1] & measureNearest .* flowers
+ src/Examples/Coalgebraic.hs view
@@ -0,0 +1,10 @@+module Examples.Coalgebraic where++-- >>> [Just 1, Just 2, Just 3] & _Just >- sum+-- Just 6++-- >>> [Just 1, Nothing, Just 3] & _Just >- sum+-- Nothing++-- >>> [Right 1, Left "whoops", Right 2] & _Right >- sum+-- Left "whoops"
+ src/Examples/Diffract.hs view
@@ -0,0 +1,14 @@+module Examples.Diffract where++import Data.Pair+import Proton++split :: [a] -> Pair [a]+split x = Pair x (reverse x)++splitter :: (a, a) -> Pair a+splitter (a, b) = Pair a b++example :: IO ()+example = do+    print $ diffract (traversed . traversed) splitter [[(1, 2), (3, 4)], [(5, 6), (7, 8 :: Int)]]
+ src/Examples/Flowers.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Examples.Flowers where++import Proton++import Data.Profunctor.Rep+import Data.Profunctor.Strong+import Data.Profunctor.Sieve+import Data.Foldable++import qualified Data.Map as M+import Data.List+import Data.Ord+import Data.Function+import Control.Applicative+import Debug.Trace+import Data.Functor.Identity+import Proton.Algebraic+import Data.Profunctor++data Species = Setosa | Versicolor | Virginica+  deriving Show++data Measurements = Measurements {getMeasurements :: [Float]}+  deriving Show++data Flower = Flower {flowerSpecies :: Species, flowerMeasurements :: Measurements}+  deriving Show++-- measurements' :: p [Float] [Float] -> p Measurements Measurements+-- measurements' :: Lens' Measurements [Float]+-- measurements' p =++measurementDistance :: Measurements -> Measurements -> Float+measurementDistance (Measurements xs) (Measurements ys) =+    sqrt . sum $ zipWith diff xs ys+  where+    diff a b = (a - b) ** 2++-- aggregate :: Kaleidoscope' Measurements Float+aggregate :: Kaleidoscope' Measurements Float+aggregate = iso getMeasurements Measurements . pointWise++-- measureLens :: Lens' Measurements [Float]+-- measureLens = lens getMeasurements setter+--   where+--     setter _ b = Measurements b++classify :: [Flower] -> Measurements -> Maybe Flower+classify flowers m+  | null flowers = Nothing+  | otherwise =+  let Flower species _ = minimumBy+                          (comparing (measurementDistance m . flowerMeasurements))+                          flowers+   in Just $ Flower species m++-- measurements :: (Corepresentable p, Foldable (Corep p)) => Optic' p Flower Measurements+-- measurements = listLens flowerMeasurements classify++measurements :: AlgebraicLens Flower (Maybe Flower) Measurements Measurements+measurements = listLens flowerMeasurements classify++-- strained :: forall s b. ListLens s [s] s Bool+-- strained = listLens id go+--   where+--     -- go :: ([s], [Bool]) -> [s]+--     -- go  = fmap fst . filter snd . uncurry zip+--     go  (x, True)  = x+--     go  (x, False) = []++versicolor :: Flower+versicolor = Flower Versicolor (Measurements [2, 3, 4, 2])++setosa :: Flower+setosa = Flower Setosa (Measurements [5, 4, 3, 2.5])++flowers :: [Flower]+flowers = [versicolor, setosa]++mean :: Fractional a => [a] -> a+mean [] =  0+mean xs = sum xs / fromIntegral (length xs)+++infixr 4 >--+(>--) :: [s] -> Optic (Costar []) s t a a -> t+(>--) xs opt = (runCostar $ opt (Costar head)) xs++aggregateWith :: Functor f => (f Float -> Float) -> Optic (Costar []) Measurements Measurements Float Float+aggregateWith aggregator p = Costar (Measurements . fmap (cosieve p) . transpose . fmap getMeasurements)++avgMeasurement :: Foldable f => f Measurements -> Measurements+avgMeasurement ms = Measurements (mean <$> groupedMeasurements)+  where+    groupedMeasurements :: [[Float]]+    groupedMeasurements = transpose (getMeasurements <$> toList ms)+    mean :: [Float] -> Float+    mean xs = sum xs / fromIntegral (length xs)++applyWeight :: Float -> Measurements -> Measurements+applyWeight w (Measurements m) = Measurements (fmap (*w) m)++partitioned :: forall f a. (Ord a) => AlgebraicLens a ([a], [a]) a a+partitioned = listLens id splitter+  where+    -- splitter :: f a -> a -> ([a], [a])+    splitter xs ref+      = (filter (< ref) (toList xs), filter (>= ref) (toList xs))++onFirst :: Eq a => AlgebraicLens (a, b) (Maybe b) a a+onFirst = listLens fst picker+  where+    picker xs a = lookup a $ toList xs++selectingOn :: (s -> a) -> AlgebraicLens s (Maybe s) a (Maybe Int)+selectingOn project = listLens project picker+  where+    picker xs i = (toList xs !!) <$> i++indexOf :: Eq s => AlgebraicLens s (Maybe Int) s s+indexOf = listLens id (flip elemIndex . toList)++test :: IO ()+test = do+    -- print $ [1..10] & partitioned ?- (5 :: Int)+    -- print $ [1..10] & partitioned >- mean+    -- print $ ["banana", "pomegranate", "watermelon"] & selectingOn length >- elemIndex 11+    -- print $ ["banana", "pomegranate", "watermelon"] & selectingOn length . indexOf ?- 11+    -- print $ Identity "banana" & selectingOn length . indexOf %~ (+10)+    -- print $ (flowers >-- (measurements . aggregateWith mean))+    print $ flowers & (measurements . aggregate >- mean)+    -- We can use a list-lens as a setter over a single element+    -- print $ versicolor & measurements . aggregate %~ negate++    -- -- We can explicitly compare to a specific result+    -- print $ (flowers !! 1) ^. measurements+    -- print $ (flowers ?. measurements) $ Measurements [5, 4, 3, 1]+    -- print $ Measurements [5, 4, 3, 1] & (measurements .* flowers)+    -- print $ Measurements [5, 4, 3, 1] & measurements .* flowers++    -- -- We can provide an aggregator explicitly+    -- print $ mean & (flowers >- measurements . aggregate)+    -- print $ flowers & measurements >- avgMeasurement+    -- print $ M.fromList [(1.2, setosa), (0.6, versicolor)] & measurements >- avgMeasurement . fmap (uncurry applyWeight) . M.toList+    -- print $ flowers & (measurements . aggregate *% mean)+    -- print $ flowers & (measurements . aggregate *% mean)+    -- print $ flowers & (measurements . aggregate *% maximum)+    -- print $ [[1, 2, 3], [1, 2, 3], [1, 2, 3]] & convolving *% id+    --+++allMeasurements :: [[Float]]+allMeasurements =+      [ [1  , 2  , 3  , 4  ]+      , [10 , 20 , 30 , 40 ]+      , [100, 200, 300, 400]+      ]++measurementMap :: M.Map String (ZipList Float)+measurementMap = M.fromList+      [ ("setosa"    , ZipList [1  , 2  , 3  , 4  ])+      , ("versicolor", ZipList [10 , 20 , 30 , 40 ])+      , ("virginica" , ZipList [100, 200, 300, 400])+      ]
+ src/Examples/Glass.hs view
@@ -0,0 +1,7 @@+module Examples.Glass where++import Proton+import Data.Profunctor+import Data.List.NonEmpty++-- test =
+ src/Examples/Layers.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-}+module Examples.Layers where++import Proton+import Data.Profunctor+import Data.Profunctor.Rep+import Data.Profunctor.MStrong+import Proton.Algebraic+import qualified Data.Map as M+import Data.Foldable+import Data.Maybe++imgLayers :: [[Int]]+imgLayers = [ [0, 1, 0, 1]+            , [2, 3, 3, 2]+            ]++-- done :: [Int]+-- done = imgLayers & pointWise *% head . dropWhile (== 0)++-- selector :: (Ord k, Corep p ~ M.Map k, Corepresentable p) => Optic p s [Maybe s] s [k]+-- selector = listLens id (\(m, k) -> flip M.lookup m <$> k)++-- done' = M.fromList [(1 :: Int, [1, 10]), (2, [2, 20]), (3, [3, 30])]  & selector . convolving *% M.findWithDefault 99 1++forward :: Profunctor p => (s -> a) -> Optic p s t a t+forward f = lmap f++back :: Profunctor p => (x -> t) -> Optic p s t s x+back f = rmap f++lookup'er :: Eq a => AlgebraicLens (a, b) (a, Maybe b) a a+lookup'er = listLens fst (\xs i -> (i, lookup i xs))++-- test :: IO ()+-- test = do+--     print $ [([1, 2] , "one" :: String), ([10, 0], "two")] & lookup'er . pointWise *% maximum
+ src/Examples/Loop.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+module Examples.Loop where++import Proton.Loop+import Proton+import Data.Profunctor+import Data.Monoid++thing :: Loop' Int Int+thing = loop id step+  where+    step 0 = Right 0+    step n = Left n++-- factorial :: Int -> Maybe (Int, Product Int)+-- factorial 0 = Nothing+-- factorial n = Just (n - 1, Product n)++collatz :: Int -> [Int]+collatz n = n & while (/= 1) (:[]) %~ step+  where+    step x+      | even x = x `div` 2+      | otherwise = (3 * x) + 1++-- >>> collatz 3+-- [3,10,5,16,8,4,2]+-- >>> collatz 5+-- [5,16,8,4,2]++factorial :: Int -> Product Int+factorial n = n & while (/= 0) Product %~ subtract 1++-- >>> factorial 3+-- Product {getProduct = 6}+-- >>> factorial 6+-- Product {getProduct = 720}++accum :: forall p next state. (Monoid state, Strong p, Cochoice p)+      => (next -> Maybe (next, state)) -> Optic p next state next next+accum check = loop initialize step . _1+  where+    initialize n = case check n of+        Nothing -> (n, mempty)+        Just (_, s) -> (n, s)+    step :: (next, state) -> Either (next, state) state+    step (n, s) =+        case check n of+            Nothing -> Right s+            Just (n', s') -> Left (n', s <> s')++while :: (Monoid state, Strong p, Cochoice p)+      => (t -> Bool)+      -> (t -> state)+      -> Optic p t state t t+while continue inj = accum $ \x -> if continue x+    then Just (x, inj x)+    else Nothing+
+ src/Examples/Scrap.hs view
@@ -0,0 +1,78 @@+module Examples.Scrap where++import Linear+import Proton+import Data.Ord+import Data.List+import Data.Profunctor.Distributing+import Proton.Algebraic+import Data.Profunctor.Closed+import Data.Profunctor.Rep+import Debug.Trace+import qualified Data.Map as M+import Data.Distributive+import Control.Applicative+import Data.Functor.Identity+import Data.Profunctor.Reflector++data Species = Setosa | Versicolor | Virginica+  deriving Show++data Measurements = Measurements {getMeasurements :: V4 Float}+  deriving Show+++data Flower = Flower {species :: Species, measurements :: Measurements}+  deriving Show++measurementDistance :: Measurements -> Measurements -> Float+measurementDistance (Measurements xs) (Measurements ys) = sum . abs $  xs - ys++classify :: Foldable f => f Flower -> Measurements -> Flower+classify flowers m =+    let Flower species _ = minimumBy (comparing (measurementDistance m . measurements)) flowers+     in Flower species m++aggregate :: Kaleidoscope' Measurements Float+aggregate = iso getMeasurements Measurements . reflected++measureNearest :: AlgebraicLens' Flower Measurements+measureNearest = listLens measurements classify++flower1 :: Flower+flower1 = Flower Versicolor (Measurements (V4 2 3 4 2))++flower2 :: Flower+flower2 = Flower Setosa (Measurements (V4 5 4 3 2.5))++flowers :: [Flower]+flowers = [flower1, flower2, flower1]++mean :: [Float] -> Float+mean [] =  0+mean xs = sum xs / fromIntegral (length xs)++-- compVectors :: (Applicative f) => AlgebraicLens Int (f Int) Int (f Int)+-- compVectors = algebraic pure _ (liftA2 (+))++aggOnIndex :: (s -> a) -> AlgebraicLens s b a b+aggOnIndex f = listLens f (flip const)++test :: IO ()+test = do+    print ()+    -- We can use a list-lens as a setter over a single element+    -- print $ flower1 & measureNearest . aggregate %~ negate++    -- -- We can explicitly compare to a specific result+    -- print $ Measurements [5, 4, 3, 1] & flowers ?. measureNearest+    -- print $ Measurements [5, 4, 3, 1] & measureNearest .* flowers++    -- -- We can provide an aggregator explicitly+    -- print $ mean & (flowers >- measureNearest . aggregate)+    -- print $ flowers & (measureNearest . aggregate *% mean)+    -- print $ flowers & measureNearest . aggregate *% maximum . traceShowId+    -- print . sequenceA $ [V2 1 2, V2 10 20, V2 100 200] & distribute' . compVectors *% const [2, 3, 4]+    -- print $ flower1 & measureNearest . aggregate %~ (+10)+    -- print $ flower1 ^. measureNearest . aggregate+    -- print $ [[1, 2, 3], [3, 4, 5]] & convolving *% mean
+ src/Proton.hs view
@@ -0,0 +1,27 @@+module Proton (+    module P+    ) where++import Data.Profunctor.Extraction as P+import Proton.Achromatic as P+import Proton.Algebraic as P+import Proton.Coalgebraic as P+import Proton.Feedback as P+import Proton.Fold as P+import Proton.Getter as P+import Proton.Glass as P+import Proton.Grate as P+import Proton.Grid as P+import Proton.Iso as P+import Proton.Kaleidoscope as P+import Proton.Diffraction as P+import Proton.Lens as P+import Proton.Loop as P+import Proton.Prisms as P+import Proton.Review as P+import Proton.Setter as P+import Proton.Traversal as P+import Proton.Indexed as P+import Proton.Types as P++import Data.Function as P ((&))
+ src/Proton/Achromatic.hs view
@@ -0,0 +1,17 @@+module Proton.Achromatic where++import Data.Profunctor+import Data.Profunctor.Strong+import Proton.Lens++achrom :: forall s t a b+       . (s -> Maybe (b -> t))+       -> (s -> a)+       -> (b -> t)+       -> Lens s t a b+achrom try proj rev p = strong go $ lmap proj p+  where+    go :: s -> b -> t+    go s b = case try s of+        Nothing -> rev b+        Just f -> f b
+ src/Proton/Algebraic.hs view
@@ -0,0 +1,46 @@+module Proton.Algebraic+    ( MStrong(..)+    , AlgebraicLens+    , AlgebraicLens'+    , algebraic+    , listLens+    , altLens+    , (>-)+    , (?.)+    ) where++import Data.Profunctor+import Data.Profunctor.MStrong+import Proton.Types+import Data.Monoid+import Control.Applicative+import Control.Arrow++type AlgebraicLens s t a b = forall p. MStrong p => p a b -> p s t+type AlgebraicLens' s a = AlgebraicLens s s a a++algebraic :: forall m p s t a b+           . (Monoid m,  MStrong p)+           => (s -> m)+           -> (s -> a)+           -> (m -> b -> t)+           -> Optic p s t a b+algebraic inject project flatten p+  = dimap (inject &&& id)  (uncurry flatten) $  strengthened+  where+    strengthened :: p (m, s) (m, b)+    strengthened = msecond' (lmap project p)++listLens :: MStrong p => (s -> a) -> ([s] -> b -> t) -> Optic p s t a b+listLens = algebraic pure++altLens :: (Alternative f, MStrong p) => (s -> a) -> (f s -> b -> t) -> Optic p s t a b+altLens project flatten = algebraic (Alt . pure)  project (flatten . getAlt)++infixr 4 ?.+(?.) :: Optic (Costar f) s t a b -> b -> f s -> t+(?.) opt b xs = (runCostar $ opt (Costar (const b))) xs++infixr 4 >-+(>-) :: Optic (Costar f) s t a b -> (f a -> b) -> f s -> t+(>-) opt aggregator xs = (runCostar $ opt (Costar aggregator)) xs
+ src/Proton/Annotated.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Proton.Annotated where++import Data.Profunctor+import Data.Profunctor.Traversing+import Data.Profunctor.Coindexed+import Proton.Types+import Proton.Setter+++-- coindexing :: (Coindexable i p q) => (s -> i) -> p s t -> q s t+-- coindexing f p = lmap (f &&& id) $ coindexed p++-- itraversed :: (Coindexable Int p q, Traversing q) => p a b -> q [a] [b]+-- vFirst :: CoindexedOptic String p [a] [b] a b+-- vFirst p = _ $ coindexed p++vView :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a+vView lns = runForget . runCoindexed $ lns (Forget Right)++-- vToListOf :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a+-- vToListOf lns = runForget . runCoindexed $ lns (Forget Right)++coindexing :: forall e p s t a b. Profunctor p =>+    Optic (Coindexed e p) s t a b -> Optic p s (Either e t) a b+coindexing o p = runCoindexed . o $ Coindexed (rmap Right p)++-- itoListOf :: CoindexedOptic e (Forget [a]) s t a b -> s -> [(i, a)]+-- itoListOf fld = _ (fld (Forget pure))++vOver :: Optic (Coindexed e (->)) s t a b -> (a -> b) -> s -> Either e t+vOver modifier f s = over (coindexing modifier) f s++-- vFirst :: forall p a. Choice p => p a a -> Coindexed String p [a] [a]+-- vFirst p = Coindexed (dimap _ _ $ right' p)+--   where+--     -- passThrough :: p (Either [a] (a, [a])) (Either [a] (a, [a]))+--     passThrough = dimap _ _ $ right' p++vFirst :: forall p a. Traversing p => p a a -> Coindexed String p [a] [a]+vFirst p = Coindexed (wander go p)+  where+    go :: forall f. Applicative f => (a -> f a) -> [a] -> f (Either String [a])+    go _ [] = pure (Left "No first element to list")+    go f (x : xs) = Right . (:xs) <$> f x++-- iset :: CoindexedOptic i (->) s t a b -> (i -> b) -> s -> t+-- iset setter f = iover setter (\i _ -> f i)
+ src/Proton/Coalgebraic.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE InstanceSigs #-}+module Proton.Coalgebraic where++import Proton.Types+import Data.Profunctor+import Proton.Prisms+import Proton.Review++type Coalgebraic s t a b = forall p. MChoice p => Optic p s t a b+type Coalgebraic' s a = Coalgebraic s s a a++swapEither :: Either a b -> Either b a+swapEither (Left a) = Right a+swapEither (Right a) = Left a++class Profunctor p => MChoice p where+  mleft' :: p a b -> p (Either a m) (Either b m)+  mleft' = dimap swapEither swapEither . mright'+  mright' :: p a b -> p (Either m a) (Either m b)+  mright' = dimap swapEither swapEither . mleft'++instance MChoice (->) where+  mright' = right'++instance Applicative f => MChoice (Star f) where+  mright' = right'++instance (Monoid r) => MChoice (Forget r) where+  mright' = right'++instance Traversable f => MChoice (Costar f) where+  mright' :: forall a b m. Costar f a b -> Costar f (Either m a) (Either m b)+  mright' (Costar f) = (Costar (fmap f . sequenceA))++coprism :: (b -> t) -> (s -> Either t a) -> Coalgebraic s t a b+coprism rev split = dimap split (either id rev) . mright'++coalgPrism :: Prism s t a b -> Coalgebraic s t a b+coalgPrism pr = coprism (review pr) (matching pr)++_Just' :: Coalgebraic (Maybe a) (Maybe b) a b+_Just' = coalgPrism _Just++_Right' :: Coalgebraic (Either e a) (Either e b) a b+_Right' = coalgPrism _Right
+ src/Proton/Coindexed.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Proton.Coindexed where++import Data.Profunctor+import Data.Profunctor.Traversing+import Data.Profunctor.Coindexed+import Proton.Types+import Proton.Setter+import Proton.Prisms+import Proton.Fold+import Data.Monoid+++-- coindexing :: (Coindexable i p q) => (s -> i) -> p s t -> q s t+-- coindexing f p = lmap (f &&& id) $ coindexed p++-- itraversed :: (Coindexable Int p q, Traversing q) => p a b -> q [a] [b]+-- vFirst :: CoindexedOptic String p [a] [b] a b+-- vFirst p = _ $ coindexed p++vView :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a+vView lns = runForget . runCoindexed $ lns (Forget Right)++vPrism :: (Coindexable e p q, Choice p, Choice q) => (t -> e) -> Prism s t a b -> Optical p q s t a b+vPrism f pr q = withPrism pr $ \proj match ->+    coindexed . rmap (either (Left . f) (Right . proj)) . lmap match $ right' q++_Just' :: (Choice p, Choice q, Coindexable String p q) => Optical p q (Maybe a) (Maybe b) a b+_Just' = vPrism (const "Expected Just but got Nothing") _Just++-- vToListOf :: CoindexedOptic e (Forget (Either e a)) s t a b -> s -> Either e a+-- vToListOf lns = runForget . runCoindexed $ lns (Forget Right)++coindexing :: forall e p s t a b. Profunctor p =>+    Optic (Coindexed e p) s t a b -> Optic p s (Either e t) a b+coindexing o p = runCoindexed . o $ Coindexed (rmap Right p)++-- itoListOf :: CoindexedOptic e (Forget [a]) s t a b -> s -> [(i, a)]+-- itoListOf fld = _ (fld (Forget pure))++vOver :: Optic (Coindexed e (->)) s t a b -> (a -> b) -> s -> Either e t+vOver modifier f s = over (coindexing modifier) f s++-- vFirst :: forall p a. Choice p => p a a -> Coindexed String p [a] [a]+-- vFirst p = Coindexed (dimap _ _ $ right' p)+--   where+--     -- passThrough :: p (Either [a] (a, [a])) (Either [a] (a, [a]))+--     passThrough = dimap _ _ $ right' p++-- (^??) :: forall e s t a b p q. s -> Optical p q s t a b ->  Either e a+-- (^??) s o = maybe (undefined) Right (s ^? (o @(Forget (First a)) @(Forget (First a))))++vFirst :: forall p a. Traversing p => p a a -> Coindexed String p [a] [a]+vFirst p = Coindexed (wander go p)+  where+    go :: forall f. Applicative f => (a -> f a) -> [a] -> f (Either String [a])+    go _ [] = pure (Left "No first element to list")+    go f (x : xs) = Right . (:xs) <$> f x++-- iset :: CoindexedOptic i (->) s t a b -> (i -> b) -> s -> t+-- iset setter f = iover setter (\i _ -> f i)
+ src/Proton/Diffraction.hs view
@@ -0,0 +1,8 @@+module Proton.Diffraction where++import Data.Distributive+import Proton.Types+import Data.Profunctor++diffract :: Distributive f => Optic (Star f) s t a b -> (a -> f b) -> s -> f t+diffract opt f = runStar $ opt (Star f)
+ src/Proton/Feedback.hs view
@@ -0,0 +1,36 @@+module Proton.Feedback where++import Data.Profunctor+import Proton.Types+import Proton.Setter+import Data.Function+import Debug.Trace++type Feedback s t a b = forall p. Costrong p => p a b -> p s t+type Feedback' s a = Feedback s s a a++-- Simplified:+-- feedback :: forall p s t a b state. Costrong p+--      => ((a, b) -> b) -> (b -> (a, b)) -> Optic' p a b+feedback :: forall p s t a b. Costrong p+     => ((s, b) -> a) -> (b -> (t, b)) -> Optic p s t a b+feedback ping pong = unfirst . dimap ping pong++-- factorial :: Feedback' Int Int+-- factorial = feedback ping pong+--   where+--     ping :: (Int, Int) -> Int+--     ping ~(new, acc) = new * acc+--     pong :: Int -> (Int, Int)+--     pong n = (n - 1, 3)++fib :: Feedback Int [Int] [Int] [Int]+fib = feedback ping pong+  where+    ping :: ((Int, [Int]) -> [Int])+    ping (n, xs) = take n xs+    pong :: [Int] -> ([Int], [Int])+    pong xs = (reverse xs, xs)++-- >>> 10 & fib %~ \xs -> 1 : 1 : zipWith (+) xs (tail xs)+-- [1,1,2,3,5,8,13,21,34,55,89]
+ src/Proton/Fold.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE InstanceSigs #-}+module Proton.Fold where++import Data.Profunctor+import Data.Profunctor.Traversing+import Data.Profunctor.Phantom+import Data.Monoid+import Proton.Types+import Data.Foldable++type Fold s t a b = forall p. (Traversing p, Phantom p) => p a b -> p s t++folding :: (Foldable f, Phantom p, Traversing p) => (s -> f a) -> p a b -> p s t+folding f = phantom . lmap (toList . f) . traverse'++folded :: (Traversing p, Foldable f, Phantom p)+       => p a b -> p (f a) t+folded = phantom . lmap toList . traverse'++foldOf :: Monoid a => Fold s t a b -> s -> a+foldOf f = runForget (f (Forget id))++foldMapOf :: Monoid m => Optic (Forget m) s t a b -> (a -> m) -> s -> m+foldMapOf f into = runForget (f (Forget into))++toListOf :: Optic (Forget [a]) s t a b -> s -> [a]+toListOf fld = foldMapOf fld pure++preview :: Optic (Forget (First a)) s t a b -> s -> Maybe a+preview fld = getFirst . foldMapOf fld (First . Just)++(^?) :: s -> Optic (Forget (First a)) s t a b -> Maybe a+(^?) = flip preview++(^..) :: s -> Optic (Forget [a]) s t a b -> [a]+(^..) = flip toListOf++(<+>) :: Semigroup r => Optic (Forget r) s t a b -> Optic (Forget r) s t' a b' -> Optic (Forget r) s t a b+(fldA <+> fldB) p = +    case (fldA p, fldB (phantom p)) of+        (Forget f, Forget g) -> Forget (\a -> f a <> g a)
+ src/Proton/Getter.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE QuantifiedConstraints #-}+module Proton.Getter where++import Data.Profunctor+import Data.Profunctor.Phantom+import Proton.Types++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++view :: Optic (Forget a) s t a b -> s -> a+view g = runForget . g $ Forget id++views :: Optic (Forget a) s t a b -> (a -> a') -> s -> a'+views g f = f . view g++like :: a -> Getter s t a b+like = to . const++infixl 8 ^.+(^.) ::  s -> Optic (Forget a) s t a b -> a+(^.) = flip view
+ src/Proton/Glass.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ConstraintKinds #-}+module Proton.Glass where++import Data.Profunctor+import Control.Comonad+import Proton.Types+import Proton.Internal.Orphans+import Proton.Lens+import Proton.Setter+import Proton.Getter++type Glass s t a b = forall p. (Strong p, Closed p) => Optic p s t a b+type Glass' s a = Glass s s a a++-- class Glassy p where+--   glass :: (((s -> a) -> b) -> s -> t) -> p a b -> p s t++type Glassed p = (Strong p, Closed p)+glassed :: (Strong p, Closed p) => p a b -> p (s, u -> a) (s, u -> b)+glassed = second' . closed++glass :: forall p s t a b. Glassed p => (((s -> a) -> b) -> s -> t) -> p a b -> p s t+glass glasser p = dimap l r $ glassed p+  where+    l :: s -> (s, (s -> a) -> a)+    l s = (s, ($ s))+    r :: (s, (s -> a) -> b) -> t+    r (s, f) = glasser f s++glassList :: forall a b. Glass [a] [b] a b+glassList = glass go+  where+    go :: (([a] -> a) -> b) -> [a] -> [b]+    go f s = undefined++extendOf :: (Comonad w) => Optic (Costar w) s t a b -> (w a -> b) -> w s -> w t+extendOf gr f = extend (runCostar $ gr (Costar f))++traversed' :: forall f a b. Traversable f => Glass (f a) (f b) a b+traversed' = glass go+  where+    go :: ((f a -> a) -> b) -> f a -> f b+    go f fa = undefined++-- instance Comonad f => Strong (Costar f) where+--   first' (Costar f) = (Costar (extract . extend (\x -> (, snd . extract $ x) $ f (fst <$> x))))++++-- instance Comonad f => Glassy (Costar f) where+--   glass glasser (Costar fab) = Costar (\s -> extract $ fmap (glasser (go s)) s)+--     where+--       go fs sToA = fab $ fmap sToA fs++-- instance (Functor f) => Glassy (Costar f) where+--   glass glasser (Costar fab) = Costar (\fs -> flip glasser $ collect go fs)+--     where+--       go :: s -> _ -> b+--       go = undefined+--       go s sToA = fab $ fmap sToA fs+++-- type Glass = Glassy p => p a b -> p s t++-- glass :: Comonad w => (((s -> a) -> b) -> s -> t) -> GrateLike w s t a b+-- glass glasser f s = (glasser $ \h -> f (h <$> s)) $ extract s++-- Move this somewhere+-- instance (Comonad w) => Strong (Costar w) where+--   first' :: forall a b c. Costar w a b -> Costar w (a, c) (b, c)+--   first' (Costar f) = Costar go+--     where+--       go :: (w (a, c) -> (b, c))+--       go wac = extract $ extendThrough (lensGlass _1) f wac
+ src/Proton/Grate.hs view
@@ -0,0 +1,49 @@+module Proton.Grate where++import Data.Profunctor+import Data.Function ((&))+import Data.Functor.Rep+import Proton.Types+import Data.Pair++type Grate s t a b = forall p. Closed p => (p a b) -> (p s t)+type Grate' s a = Grate s s a a++newtype Zipping a b = Zipping (a -> a -> b)++grate :: (((s -> a) -> b) -> t) -> Grate s t a b+grate g = dimap (&) g . closed++distributed :: (Closed p, Representable g) => p a b -> p (g a) (g b)+distributed = dimap index tabulate . closed++both :: Grate (a, a) (b, b) a b+both = paired . distributed++zipWithOf :: forall s t a b. Optic (Costar Pair) s t a b -> (a -> a -> b) -> s -> s -> t+zipWithOf g f s1 s2 = zipFWithOf g (liftPair f) (Pair s1 s2)++-- degrating :: Grate s t a b -> ((s -> a) -> b) -> t+-- degrating g f = undefined++-- Equivalent to `>-` from Algebraic lenses, but with different semantics+zipFWithOf :: forall f s t a b. Optic (Costar f) s t a b -> (f a -> b) -> (f s -> t)+zipFWithOf g fab fs = grated fs+  where+    grated :: f s -> t+    Costar grated = g (Costar fab)++-- extendThrough :: forall s t a b w. Comonad w => Grate s t a b -> (w a -> b) -> w s -> w t+-- extendThrough g f = extend (degrated . helper)+--   where+--     helper :: w s -> (s -> a) -> b+--     helper w' sToA = f (sToA <$> w')+--     degrated :: ((s -> a) -> b) -> t+--     degrated = degrating g++-- extendThrough :: forall s t a b w. Comonad w => Grate s t a b -> (w a -> b) -> w s -> w t+-- extendThrough g f = extend (degrated . helper)++-- (-<) :: Comonad w => Grate s t a b -> (w a -> b) -> w s -> w t+-- (-<) = extendThrough+
+ src/Proton/Grid.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TypeFamilies #-}+module Proton.Grid where++import Data.Profunctor+import Data.Profunctor.Traversing+import Proton.Types+import Proton.Grate+import Data.Pair+import Proton.Setter+import Proton.Traversal++type Grid s t a b = forall p. (Traversing p, Closed p) => Optic p s t a b+type Grid' s a = Grid s s a a++-- bothT :: Traversal (a, a) (b, b) a b+-- bothT p = _ $ traverse' p++-- beside :: Optic p s t a b -> Optic p s' t' a b -> Optic p (s, s') (t, t') a b+-- beside l r = distributed
+ src/Proton/Indexed.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Proton.Indexed where++import Data.Profunctor+import Data.Profunctor.Traversing+import Control.Arrow ((&&&))+import Data.Profunctor.Indexed+import Proton.Types++indexing :: (Indexable i p q) => (s -> i) -> p s t -> q s t+indexing f p = lmap (f &&& id) $ indexed p++-- itraversed :: (Indexable Int p q, Traversing q) => p a b -> q [a] [b]+itraversed :: Traversing p => IndexedOptic Int p [a] [b] a b+itraversed p = lmap (zip [(0 :: Int)..]) . traverse' $ indexed p++itoListOf :: IndexedOptic i (Forget [(i, a)]) s t a b -> s -> [(i, a)]+itoListOf fld = runForget (fld (Indexed (Forget pure)))++iover :: IndexedOptic i (->) s t a b -> (i -> a -> b) -> s -> t+iover setter f = setter (Indexed (uncurry f))++iset :: IndexedOptic i (->) s t a b -> (i -> b) -> s -> t+iset setter f = iover setter (\i _ -> f i)
+ src/Proton/Internal/Orphans.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE TupleSections #-}+module Proton.Internal.Orphans where++import Data.Profunctor+import Control.Comonad+-- import Proton.Types+-- import Proton.Setter+-- import Proton.Getter++-- Steal this from Cokleisli at some point+-- instance Comonad w => Choice (Costar w) where++instance Comonad f => Strong (Costar f) where+  -- Not quite right+  first' (Costar f) = (Costar (extract . extend (\x -> (, snd . extract $ x) $ f (fst <$> x))))++-- Don't think this is useful for anything; but we can get a Strong instance for Costar+-- using an adjunction between Star/Costar through (,) (->).++-- instance Strong (Costar ((,) e)) where+--   second' co = costarFlip $ second' (starFlip co)++-- starFlip :: Costar ((,) e) a b -> Star ((->) e) a b+-- starFlip (Costar f) = Star (\e a ->  f (a, e))++-- costarFlip :: Star ((->) e) a b -> Costar ((,) e) a b+-- costarFlip (Star f) = Costar (\(e, a) ->  f a e)
+ src/Proton/Iso.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveFunctor #-}+module Proton.Iso where++import Data.Profunctor+import Proton.Getter+import Proton.Review++type Iso s t a b = forall p. Profunctor p => p a b -> p s t+type Iso' s a = Iso s s a a++iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso = dimap++from :: Iso s t a b -> Iso b a t s+from i = withIso i $ flip iso++withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r+withIso i handler =+    case i (Exchange id id) of+        Exchange f g -> handler f g++under :: Iso s t a b -> (t -> s) -> b -> a+under i ts b = withIso i $ \sa bt -> (sa . ts . bt $ b)++mapping :: (Functor f, Functor g) => Iso s t a b -> Iso (f s) (g t) (f a) (g b)+mapping i = dimap (fmap (view i)) (fmap (review i))++involuted :: (a -> a) -> Iso' a a+involuted f = iso f f++data Exchange a b s t =+    Exchange (s -> a) (b -> t)+  deriving Functor++instance Profunctor (Exchange a b) where+  dimap f' g' (Exchange f g) = Exchange (f . f') (g' . g)
+ src/Proton/Kaleidoscope.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Proton.Kaleidoscope (Reflector(..), Kaleidoscope, Kaleidoscope', pointWise) where++-- ala http://events.cs.bham.ac.uk/syco/strings3-syco5/slides/roman.pdf+-- https://cs.ttu.ee/events/nwpt2019/abstracts/paper14.pdf++import Data.Profunctor+import Control.Applicative+import Data.Profunctor.Reflector++type Kaleidoscope s t a b = forall p. Reflector p => p a b -> p s t+type Kaleidoscope' s a = Kaleidoscope s s a a++pointWise :: Kaleidoscope [a] [b] a b+pointWise = dimap ZipList getZipList . reflected++-- collapse :: forall p f a b c g. (Traversable g, Applicative g, Alternative f, Corepresentable p, Corep p ~ g)+--         => Optic' p (f a) a+-- collapse p = cotabulate done+--   where+--     func :: g (f a) -> (f a)+--     func = cosieve (convolving p)+--     done :: g (f a) -> f a+--     done = func . pure @g . asum
+ src/Proton/Lens.hs view
@@ -0,0 +1,19 @@+module Proton.Lens where++import Data.Profunctor+import Data.Profunctor.Strong+import Control.Arrow ((&&&))++type Lens s t a b = forall p. Strong p => p a b -> p s t+type Lens' s a = Lens s s a a++lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+-- lens getter setter = strong setter . lmap getter+lens getter setter = dimap (id &&& getter) (uncurry setter) . second'++_1 :: Lens (a, x) (b, x) a b+_1 = lens fst (\(_, x) b -> (b, x))+++_2 :: Lens (x, a) (x, b) a b+_2 = lens snd (\(x, _) b -> (x, b))
+ src/Proton/Loop.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE InstanceSigs #-}+module Proton.Loop where++import Data.Profunctor+import Data.Profunctor.Traversing+import Proton.Types+import Data.Profunctor.Choice++-- Cochoice represents iteration/looping++type Loop s t a b = forall p. Cochoice p => p a b -> p s t+type Loop' s a = Loop s s a a++data CoPrism a b s t = CoPrism (s -> a) (b -> Either a t)++instance Profunctor (CoPrism a b) where+  dimap f g (CoPrism project match) = CoPrism (project . f) (fmap g . match)++instance Cochoice (CoPrism a b) where+  unright :: forall d a' b'. CoPrism a b (Either d a') (Either d b') -> CoPrism a b a' b'+  unright (CoPrism project match) = CoPrism (project . Right) (go . match)+    where+      go :: Either a (Either d b') -> Either a b'+      go (Left a) = Left a+      go (Right (Right b)) = Right b+      go (Right (Left d)) = Left (project $ Left d)++loop :: forall p s t a b. Cochoice p+     => (s -> a) -> (b -> Either a t) -> Optic p s t a b+loop inject step = unright . dimap (either id inject) step++-- loop' :: forall p s t a b. (Cochoice p, Traversing p)+--      => (s -> a) -> (b -> Either a t) -> Optic p s t a b+-- loop' inject step = unright . dimap (either id inject) step+++-- iterM :: forall s t a b . Optic (Star ((,) [a])) s t a b -> (a -> Either a b) -> s -> ([a], t)+-- iterM o f s = g s+--   where+--     Star (g :: s -> ([a], t)) = (o . unright . lmap (either id id)) $ Star (wrapper . f)+--     wrapper :: Either a b -> ([a], Either a b)+--     wrapper (Left a) = ([a], Left a)+--     wrapper (Right b) = ([], Right b)++iterM :: forall s t a . Optic (Star ((,) [a])) s t a a -> (a -> Either a a) -> s -> ([a], t)+iterM o f s = g s+  where+    Star (g :: s -> ([a], t)) = o . unright . lmap (either id id) $ Star (wrapper . f)+    wrapper :: Either a a -> ([a], Either a a)+    wrapper (Left a) = ([a], Left a)+    wrapper (Right b) = ([b], Right b)+++++tester :: Int -> Either Int Int+tester a +  | a < 10 = Left (succ a)+  | otherwise = Right (succ a)+++-- iter :: forall f p s t a b. (Alternative f,  Cochoice p)+--      => Optic p s t a b+-- iter = _
+ src/Proton/Miso.hs view
@@ -0,0 +1,8 @@+module Proton.Miso where++import Data.Profunctor++data Miso m a b s t = Miso (s -> m a) (b -> m t)++instance Functor m => Profunctor (Miso m a b) where+  dimap l r (Miso sma bmt) = Miso (sma . l) (fmap r . bmt)
+ src/Proton/Plated.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Proton.Plated where++import Data.Profunctor+import Proton.Traversal+import Proton.Lens+import Proton.Fold+import Control.Monad.State+import Control.Applicative+import Proton.Setter+
+ src/Proton/PreGrate.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE TupleSections #-}+module Proton.PreGrate where++import Proton.Grate+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Profunctor+import Data.Maybe+import Proton.Types+import Data.Pair+import Data.Functor.Rep+import Data.Distributive+import Data.Functor.Contravariant+import Control.Comonad+import qualified Data.List.NonEmpty as NE+import Data.Profunctor.MStrong+import Data.Semigroup+import Data.Coerce+++alignMaybeWithDefault :: a -> Grate (Maybe a) (Maybe b) a b+alignMaybeWithDefault def = dimap (fromMaybe def) Just++aligner :: (s -> k -> a) -> ((k -> b) -> t) -> Grate s t a b+aligner index generate = dimap index generate . closed++alignMap :: (Ord k) => S.Set k -> Grate (M.Map k a) (M.Map k b) (Maybe a) (Maybe b)+alignMap keys = dimap (flip M.lookup) project . closed+  where+    project f = M.fromList . catMaybes $ ((\k -> (k,) <$> f k) <$> S.toList keys)++alignMapWithDefault :: (Ord k) => S.Set k -> a -> Grate (M.Map k a) (M.Map k b) a b+alignMapWithDefault keys def = alignMap keys . dimap (fromMaybe def) Just++alignList :: Int -> Grate [a] [b] (Maybe a) (Maybe b)+alignList bound = dimap (flip safeIndex) (\f -> catMaybes $ fmap f [0..bound-1] ) . closed+  where+    safeIndex :: Int -> [x] -> Maybe x+    safeIndex _ [] = Nothing+    safeIndex n _ | n < 0 = Nothing+    safeIndex 0 (x:_) = Just x+    safeIndex n (_:xs) = safeIndex (n-1) xs++alignListWithDefault :: Int -> a -> Grate [a] [b] a b+alignListWithDefault bound def = alignList bound . dimap (fromMaybe def) Just++alignMapMonoid :: (Monoid a, Ord k) => (S.Set k) -> Grate (M.Map k a) (M.Map k b) a b+alignMapMonoid n = alignMapWithDefault n mempty++alignListMonoid :: Monoid a => Int -> Grate [a] [b] a b+alignListMonoid n = alignListWithDefault n mempty++x :: M.Map Int [String]+x = M.fromList [(1, ["Gala", "Spartan", "Fuji"])]++y :: M.Map Int [String]+y = M.fromList [(1, ["Naval", "Mandarin"]), (2, ["Watermelon"])]++l :: Grate (M.Map Int [String]) (M.Map Int [b]) String b+l = alignMapWithDefault (S.fromList [1, 2, 3]) [] . alignListWithDefault 3 "def"++l' :: Grate (M.Map Int [String]) (M.Map Int [b]) (Maybe String) (Maybe b)+l' = alignMap (S.fromList [1, 2, 3]) . alignMaybeWithDefault [] . alignList 3++newtype Intersection a = Intersection (S.Set a)+instance Ord a => Semigroup (Intersection a) where+  (<>) = coerce S.intersection++fullAlignMap :: (Ord k, MStrong p, Closed p) => p a b -> p (M.Map k a) (M.Map k b)+fullAlignMap = dimap unpack rebuild . mfirst' . closed+  where+    unpack m = (\k -> fromJust $ M.lookup k m, Just . Intersection . M.keysSet $ m)+    rebuild (f, Just (Intersection ks)) = M.fromSet f ks+    rebuild (_, Nothing) = mempty++fullAlignList :: (MStrong p, Closed p) => p a b -> p [a] [b]+fullAlignList = dimap unpack rebuild . mfirst' . closed+  where+    unpack m = (\k -> m !! k, Just (Min (length m)))+    rebuild (_, Nothing) = []+    rebuild (f, Just (Min len)) = fmap f [0..len-1]++-- instance (Comonad f) => Strong (Costar f) where+--   first' (Costar f) = Costar ((\a b -> (a (fmap fst b), snd . extract $ b)) f)++-- doAThing :: Distributive f => Optic (Star f) s t a b -> (a -> Pair b) -> s -> Pair t+-- doAThing o = o (Star )++tester :: M.Map Int [String]+tester = zipFWithOf (fullAlignMap . fullAlignList) concat [x, y]+++-- Allow splitting a record into component parts to zip as well as the "monoidal" remainder+-- Then zip the main components, mappend up the rest, and re-combine.+zipBy :: forall f p s t a b m. (Representable f, MStrong p, Closed p, Monoid m) => (s -> (f a, m)) -> (f b -> m -> t) -> p a b -> p s t+zipBy project embed = dimap unpack rebuild . mfirst' . closed+  where+    unpack :: s -> (Rep f -> a, m)+    unpack s = +        case project s of+            (fa, m) -> (index fa, m)+    rebuild :: (Rep f -> b, m) -> t+    rebuild (rep, m) = embed (tabulate rep) m++-- Strong & Closed == don't need to specify indexes, maybe I can carry them through??++-- hoistO :: Optic (Star f) s t a b -> Optic (Costar g) s t a b++-- tester :: Star ((->) Bool) a b -> Costar Pair a b+-- tester (Star f) = Costar (_ f)++-- preZipWithOf :: forall s t a b. Optic (Star ((->) Bool)) s t a b -> (a -> a -> b) -> s -> s -> t+-- preZipWithOf g f s1 s2 = zipFWithOf g (_) (_)+--   where+--     buildPair p = tabulate p+--     applyPair (Pair a b) = f a b+--     -- thin :: a -> Bool -> b+--     -- thing = ++-- -- preZipFWithOf :: forall f s t a b. Optic (Star f) s t a b -> (a -> f b) -> (s -> f t)
+ src/Proton/Prisms.hs view
@@ -0,0 +1,57 @@+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+type Prism' s a = Prism s s a a++-- dualPrism :: forall p s t a b. (Choice p, Cochoice p) => (s -> Either t a) -> (b -> Either a t) -> Optic p s t a b+-- dualPrism l r p = lmap l . go $ rmap r p+--   where+--     go :: p a (Either a t) -> p (Either t a) t+--     go = undefined++prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism build split = dimap split (either id build) . right'++prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b+prism' build maybeGet = prism build (\s -> maybe (Left s) Right $ maybeGet s)++_Just :: Prism (Maybe a) (Maybe b) a b+_Just = prism Just (maybe (Left Nothing) Right)++_Nothing :: Prism' (Maybe a) ()+_Nothing = prism' (const Nothing) (maybe (Just ()) (const Nothing))++_Left :: Prism (Either a b) (Either a' b) a a'+_Left = prism Left (either Right (Left . Right))++_Right :: Prism (Either a b) (Either a b') b b'+_Right = prism Right (either (Left . Left) Right)++_Show :: (Read a, Show a) => Prism' String a+_Show = prism show $ \s -> case reads s of+  [(a,"")] -> Right a+  _ -> Left s++withPrism :: forall s t a b r. Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r+withPrism l f = case l (Market id Right) of+  Market g h -> f g h++matching :: Prism s t a b -> s -> Either t a+matching p s = withPrism p (\_ match -> match s)++-- outside :: Representable p => APrism s t a b -> Lens (p t r) (p s r) (p b r) (p a r)++-- aside :: Prism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)+-- aside pr = _ . pr . _++-- without :: APrism s t a b -> APrism u v c d -> Prism (Either s u) (Either t v) (Either a c) (Either b d)++-- below :: Traversable f => APrism' s a -> Prism' (f s) (f a)+--+-- isn't :: Prism s t a b -> s -> Bool++-- matching :: APrism s t a b -> s -> Either t a
+ src/Proton/Review.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}++module Proton.Review where++import Data.Profunctor+import Data.Tagged+import Data.Bifunctor+import Proton.Getter+import Data.Void++type Review s t a b = forall p. (Profunctor p, Bifunctor p) => p a b -> p s t++retagged :: forall p a b s. (Profunctor p, Bifunctor p) => p a b -> p s b+retagged = first absurd . lmap absurd++review :: (Tagged a b -> Tagged s t) -> b -> t+review pab b = unTagged . pab $ Tagged b++infixr 8 #+(#) :: (Tagged a b -> Tagged s t) -> b -> t+(#) = review++reviews :: (Tagged a b -> Tagged s t) -> (t -> t') -> b -> t'+reviews r f = f . review r++re :: (Tagged a b -> Tagged s t) -> Getter b a t s+re r = to (review r)++unto :: forall (s :: *) t (a :: *) b. (b -> t) -> (Tagged a b -> Tagged s t)+unto f = rmap f . retagged++un :: Getter s t a b -> (Tagged t s -> Tagged b a)+un g = unto (view g)
+ src/Proton/Setter.hs view
@@ -0,0 +1,29 @@+module Proton.Setter where++import Data.Profunctor++type Setter s t a b = (a -> b) -> (s -> t)+type Setter' s a = Setter s s a a++set :: Setter s t a b -> s -> b -> t+set l s b = l (const b) s++over :: Setter s t a b -> (a -> b) -> s -> t+over l f s = l f s++sets :: (forall p. Profunctor p => p a b -> p s t) -> Setter s t a b+sets = id++setter :: (s -> a) -> (b -> t) -> Setter s t a b+setter f g = dimap f g++mapped :: Functor f => Setter (f a) (f b) a b+mapped = fmap++infixr 4 %~+(%~) :: Setter s t a b -> (a -> b) -> s -> t+(%~) = over++infixr 4 .~+(.~) :: Setter s t a b -> b -> s -> t+(.~) l b s = set l s b
+ src/Proton/Traversal.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE QuantifiedConstraints #-}+module Proton.Traversal where++import Control.Applicative+import Control.Monad.State+import Data.Bitraversable+import Data.Profunctor+import Data.Profunctor.Rep+import Data.Profunctor.Sieve+import Data.Profunctor.Traversing+import Proton.Fold+import Proton.Lens+import Proton.Setter+import Proton.Types++type Traversal s t a b = forall p. (Traversing p) => p a b -> p s t+type Traversal' s a = forall p. Traversing p => p a a -> p s s++traversed :: Traversable f => Traversal (f a) (f b) a b+traversed = traverse'++filtered :: (a -> Bool) -> Traversal' a a+filtered predicate = dimap partition (either id id) . left'+  where+    partition a+        | predicate a = Left a+        | otherwise = Right a++traverseOf :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t+traverseOf t = runStar . t . Star++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+    go :: r s s' -> Rep p (r t t')+    go rss = bitraverse (sieve $ t1 p) (sieve $ t2 p) rss+++unsafePartsOf :: forall s t a b. (forall p. Traversing p => p a b -> p s t) -> Lens s t [a] [b]+unsafePartsOf t = lens getter setter'+  where+    getter :: s -> [a]+    getter = toListOf t+    setter' :: s -> [b] -> t+    setter' s bs = flip evalState bs $ traverseOf t insert s+    insert :: x -> State [b] b+    insert _ = gets head <* modify tail++partsOf :: forall s a. (forall p. Traversing p => p a a -> p s s) -> Lens' s [a]+partsOf t = lens getter setter'+  where+    getter :: s -> [a]+    getter = toListOf t+    setter' :: s -> [a] -> s+    setter' s as =+        set (unsafePartsOf t) s (getZipList (ZipList as <|> ZipList (getter s)))++taking :: forall q s a. Traversing q => Int -> (forall p. Traversing p => p a a -> p s s) -> Optic' q s a+taking n t = partsOf t . wander go+  where+    go :: forall f x. Applicative f => (x -> f x) -> [x] -> f [x]+    go handler as =+      case splitAt n as of+        (prefix, suffix) -> liftA2 (<>) (traverse handler prefix) (pure suffix)++dropping :: forall s a. Int -> Traversal' s a -> Traversal' s a+dropping n t = partsOf t . wander go+  where+    go :: Applicative f => (a -> f a) -> [a] -> f [a]+    go handler as =+      case splitAt n as of+        (prefix, suffix) -> liftA2 (<>) (pure prefix) (traverse handler suffix)+++-- failing :: (forall p. Traversing p => p a b -> p s t) -> (forall p. Traversing p => p a b -> p s t) -> (Traversing p => p a b -> p s t)+-- failing f _ pab = undefined $ foldMapOf f (const (Sum 1))+    -- _ $ traverse' @_ @[] p++-- both+-- failing ()
+ src/Proton/Types.hs view
@@ -0,0 +1,14 @@+module Proton.Types where++import Data.Profunctor.Indexed+import Data.Profunctor.Coindexed++type Optic p s t a b = p a b -> p s t+type Optic' p s a = Optic p s s a a++type Optical p q s t a b = p a b -> q s t+type Optical' p q s a = Optical p q s s a a+type IndexedOptic i q s t a b = forall p. Indexable i p q => Optical p q s t a b+type IndexedOptic' i p s a = IndexedOptic i p s s a a+type CoindexedOptic e p s t a b = Optical p (Coindexed e p) s t a b+type CoindexedOptic' e p s a = CoindexedOptic e p s s a a
+ src/Proton/Wither.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Proton.Wither where++import Data.Profunctor+import Data.Profunctor.Withering+import Control.Applicative+import Proton.Types+import Proton.Prisms++type Wither s t a b = forall p. Withering p => Optic p s t a b+type Wither' s a = Wither s s a a++-- type Selector' s a = Selector s s a a+-- type Selector s t a b = forall p. (Withering p, Depending p) => Optic p s t a b+++guarding :: Alternative f => (a -> Bool) -> a -> f a+guarding p a+    | p a = pure a+    | otherwise = empty++guarded :: forall a b. (a -> Bool) -> Wither a b a b+guarded p = cull guarded'+  where+    guarded' :: forall f. Alternative f => (a -> f b) -> a -> f b+    guarded' f a+      | p a = f a+      | otherwise = empty++-- selectResult :: forall a b. (b -> Bool) -> Selector a b a b+-- selectResult p = cull _collapse . depend check+--   where+--     -- collapse :: forall f. Alternative f => (a -> f (b)) -> a -> f b+--     check :: forall f. Monad f => (a -> f b) -> a -> f (Maybe b)+--     check f a = do+--         f a >>= \b ->+--             if p b then pure $ Just b+--                    else pure $ Nothing++filterOf :: Optic (Star Maybe) s t a a -> (a -> Bool) -> s -> Maybe t+filterOf w p s = runStar (w (Star (guarding p))) s++witherPrism :: forall p s t a b. Withering p => Prism s t a b -> Optic p s t a b+witherPrism prsm =+    withPrism prsm $ \embed match ->+      let+        go :: Alternative f => (a -> f b) -> s -> f t+        go f s = +            case match s of+                Left _ -> empty+                Right a -> fmap embed $ f a+      in cull go