bifocals.hs

{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE RankNTypes        #-}

import Data.Bifunctor
import Data.Bifoldable
import Data.Bifunctor.Join
import Data.Biapplicative
import Data.Bitraversable

infixr 8 %

--(%) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(%) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c
(%) f = (fmap f .)

map1 :: (a1 -> b1) -> a1 -> b2 -> (b1, b2)
map1 = curry . first

map2 :: (a2 -> b2) -> b1 -> a2 -> (b1, b2)
map2 = curry . second




type Strong' p s a = Strong p s s a a
type Strong p s t a b = Strong2 p s s t t a a b b
type Strong2' p s1 s2 a1 a2 = Strong2 p s1 s2 s1 s2 a1 a2 a1 a2
type Strong2 p s1 s2 t1 t2 a1 a2 b1 b2 = (a1 -> a2 -> p b1 b2) -> s1 -> s2 -> p t1 t2
type Closed2 p s1 s2 t1 t2 a1 a2 b1 b2 = (p a1 a2 -> (b1, b2)) -> p s1 s2 -> (t1, t2)

type Lens' s a = Lens s s a a
type Lens s t a b = Lens2 s s t t a a b b
type Lens2' s1 s2 a1 a2 = Lens2 s1 s2 s1 s2 a1 a2 a1 a2
type Lens2 s1 s2 t1 t2 a1 a2 b1 b2 = forall p. Bifunctor p => Strong2 p s1 s2 t1 t2 a1 a2 b1 b2

type Traversal' s a = Traversal s s a a
type Traversal s t a b = Traversal2 s s t t a a b b
type Traversal2 s1 s2 t1 t2 a1 a2 b1 b2 = forall p. Biapplicative p => Strong2 p s1 s2 t1 t2 a1 a2 b1 b2

type Setting' s a = Setting s s a a
type Setting s t a b = Setting2 s s t t a a b b
type Setting2 s1 s2 t1 t2 a1 a2 b1 b2 = (a1 -> a2 -> (b1, b2)) -> s1 -> s2 -> (t1, t2)

-- Optics
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens get put = lens2 get get put put
{-# INLINE lens #-}

lens2 :: (s1 -> a1) -> (s2 -> a2) -> (s1 -> b1 -> t1) -> (s2 -> b2 -> t2) -> Lens2 s1 s2 t1 t2 a1 a2 b1 b2
lens2 get1 get2 put1 put2 f s1 s2 = bimap (put1 s1) (put2 s2) (f (get1 s1) (get2 s2))
{-# INLINE lens2 #-}

-- > foldMapOf _11 (,) (0,'a') (False,"a")
-- (0,False)
--
-- > _11 :: Lens (a, c) (b, c) a b
_11 :: Lens2 (a1, c1) (a2, c2) (b1, c1) (b2, c2) a1 a2 b1 b2
_11 f (a,c1) (b,c2) = bimap (\x -> (x, c1)) (\x -> (x, c2)) (f a b)

-- λ> foldMapOf _12 (,) (0,'a') (False,"a")
-- (0,"a")
_12 :: Lens2 (a1, c1) (c2, a2) (b1, c1) (c2, b2) a1 a2 b1 b2
_12 f (a,c1) (c2,b) = bimap (\x -> (x, c1)) (\x -> (c2, x)) (f a b)

-- λ> foldMapOf _21 (,) (0,'a') (False,"a")
-- ('a',False)
_21 :: Lens2 (c1, a1) (a2, c2) (c1, b1) (b2, c2) a1 a2 b1 b2
_21 f (c1,a) (b,c2) = bimap (\x -> (c1, x)) (\x -> (x, c2)) (f a b)

-- > foldMapOf _22 (,) (0,'a') (False,"a")
-- ('a',"a")
--
-- > _22 :: Lens (c, a) (c, b) a b

_22 :: Lens2 (c1, a1) (c2, a2) (c1, b1) (c2, b2) a1 a2 b1 b2
_22 f (c1,a) (c2,b) = bimap (\x -> (c1, x)) (\x -> (c2, x)) (f a b)

-- > toListOf zipped (0,1) ('a','b')
-- [(0,'a'),(1,'b')]
-- > foldMapOf zipped (,) ("foo","bar") ("baz","bip")
-- ("foobar","bazbip")

zipped :: Traversal2 (a1, a1) (a2, a2) (b1, b1) (b2, b2) a1 a2 b1 b2
zipped f (a1, a2) (b1, b2) = biliftA2 (,) (,) (f a1 b1) (f a2 b2)

-- > toListOf zipped1 (0,1) ('a','b')
-- [(0,'a'),(0,'a')]
zipped1 :: Traversal2 (a1, c1) (a2, c2) (b1, b1) (b2, b2) a1 a2 b1 b2
zipped1 f (a1, _a2) (b1, _b2) = biliftA2 (,) (,) (f a1 b1) (f a1 b1)

-- > toListOf zipped2 (0,1) ('a','b')
-- [(1,'b'),(1,'b')]
zipped2 :: Traversal2 (c1, a1) (c2, a2) (b1, b1) (b2, b2) a1 a2 b1 b2
zipped2 f (_a1, a2) (_b1, b2) = biliftA2 (,) (,) (f a2 b2) (f a2 b2)

-- > toListOf unzipped (0,1) (2,3)
-- [(0,1),(2,3)]
-- > foldMapOf unzipped (,) ("foo","bar") ("baz","bip")
-- ("foobaz","barbip")

unzipped :: Traversal (a, a) (b, b) a b
unzipped f (a1, a2) (b1, b2) = biliftA2 (,) (,) (f a1 a2) (f b1 b2)

-- > foldMapOf flipped (,) ("foo","bar") ("baz","bip")
-- ("bazbip","foobar")
flipped :: Traversal2 (a2, a2) (a1, a1) (b1, b1) (b2, b2) a1 a2 b1 b2
flipped f (a1, a2) (b1, b2) = biliftA2 (flip (,)) (flip (,)) (f b1 a1) (f b2 a2)


-- Operators

over :: Setting2 s1 s2 t1 t2 a1 a2 b1 b2 -> (a1 -> a2 -> (b1, b2)) -> s1 -> s2 -> (t1, t2)
over l f = l (uncurry (,) % f)

foldMapOf :: Strong2' (Const2 r) s1 s2 a1 a2 -> (a1 -> a2 -> r) -> s1 -> s2 -> r
foldMapOf l f = getConst2 % l (Const2 % f)

foldrOf :: Strong2' (Const2 (Endo r)) s1 s2 a1 a2 -> (a1 -> a2 -> r -> r) -> r -> s1 -> s2 -> r
foldrOf l f z = flip appEndo z % foldMapOf l (Endo % f)

foldlOf' :: Strong2' (Const2 (Endo (Endo r))) s1 s2 a1 a2 -> (r -> a1 -> a2 -> r) -> r -> s1 -> s2 -> r
foldlOf' l f z = flip appEndo z % foldrOf l f' (Endo id)
  where f' a1 a2 (Endo k) = Endo (\z -> k $! f z a1 a2) 

toListOf :: Strong2' (Const2 (Endo [(a1, a2)])) s1 s2 a1 a2 -> s1 -> s2 -> [(a1, a2)]
toListOf l = foldrOf l (\a b -> ((a,b):)) []

allOf
  :: Strong2' (Const2 All) s1 s2 a a2
     -> (a -> a2 -> Bool) -> s1 -> s2 -> Bool
allOf l f = getAll % foldMapOf l (All % f)
{-# INLINE allOf #-}

anyOf l f = getAny % foldMapOf l (Any % f)
{-# INLINE anyOf #-}

noneOf l f = not % anyOf l f
{-# INLINE noneOf #-}


minimumOf :: Ord a => Strong2' (Const2 (Endo (Endo (Maybe a)))) s1 s2 a a -> s1 -> s2 -> Maybe a
minimumOf l = foldlOf' l mf Nothing where
  mf Nothing a1 a2 = Just $! min a1 a2
  mf (Just r) a1 a2 = Just $! min r (min a1 a2)

maximumOf :: Ord a => Strong2' (Const2 (Endo (Endo (Maybe a)))) s1 s2 a a -> s1 -> s2 -> Maybe a
maximumOf l = foldlOf' l mf Nothing where
  mf Nothing a1 a2 = Just $! max a1 a2
  mf (Just r) a1 a2 = Just $! max r (max a1 a2)

-- < https://en.wikipedia.org/wiki/Minimax >
-- λ> minimaxOf unzipped (1,2) (3,4)
-- Just 2
-- λ> minimaxOf zipped (1,2) (3,4)
-- Just 3
minimaxOf :: Ord a => Strong2' (Const2 (Endo (Endo (Maybe a)))) s1 s2 a a -> s1 -> s2 -> Maybe a
minimaxOf l = foldlOf' l mf Nothing where
  mf Nothing a1 a2 = Just $! max a1 a2
  mf (Just r) a1 a2 = Just $! min r (max a1 a2)

-- λ> maximinOf unzipped (1,2) (3,4)
-- Just 3
-- λ> maximinOf zipped (1,2) (3,4)
-- Just 2
maximinOf :: Ord a => Strong2' (Const2 (Endo (Endo (Maybe a)))) s1 s2 a a -> s1 -> s2 -> Maybe a
maximinOf l = foldlOf' l mf Nothing where
  mf Nothing a1 a2 = Just $! min a1 a2
  mf (Just r) a1 a2 = Just $! max r (min a1 a2)

leqOf :: Ord a => Strong2' (Const2 (Endo (Endo (Maybe Bool)))) s1 s2 a a -> s1 -> s2 -> Maybe Bool
leqOf l = foldlOf' l mf Nothing where
  mf Nothing a1 a2 = Just $! a1 <= a2
  mf (Just r) a1 a2 = Just $! r && (a1 <= a2)

geqOf :: Ord a => Strong2' (Const2 (Endo (Endo (Maybe Bool)))) s1 s2 a a -> s1 -> s2 -> Maybe Bool
geqOf l = foldlOf' l mf Nothing where
  mf Nothing a1 a2 = Just $! a1 >= a2
  mf (Just r) a1 a2 = Just $! r && (a1 >= a2)

data Const2 r a b = Const2 { getConst2 :: r }

instance Bifunctor (Const2 r) where
    bimap _ _ (Const2 x) = Const2 x

instance (Monoid r) => Biapplicative (Const2 r) where
    bipure _ _ = Const2 mempty
    biliftA2 _ _ (Const2 x) (Const2 y) = Const2 (x <> y)
    --(<<*>>) = coerce (mappend :: m -> m -> m)