module Mezzolens.Unchecked
( iso
, lens, lensVL
, prism
, affineTraversal
, traversal
, sec
, module Mezzolens.Optics
, PStore
) where
import Prelude hiding (map)
import Mezzolens.Combinators
import Mezzolens.Profunctor
import Mezzolens.Optics
import Data.Functor.Identity (Identity(..))
import Data.Functor.Compose (Compose(..))
import Data.Traversable (fmapDefault, foldMapDefault)
iso :: (ta -> a) -> (b -> tb) -> Iso ta tb a b
iso = dimap
lens :: (ta -> a) -> (b -> ta -> tb) -> Lens ta tb a b
lens get set = dimap (get &&& id) (uncurry set) . _1
lensVL :: (forall f. Functor f => (a -> f b) -> ta -> f tb) -> Lens ta tb a b
lensVL l = dimap ((peek &&& pos) . l idPStore) (uncurry id) . _2
prism :: (ta -> Either tb a) -> (b -> tb) -> Prism ta tb a b
prism match beget = dimap match (id ||| beget) . _Right
affineTraversal :: (ta -> Either tb a) -> (b -> ta -> tb) -> AffineTraversal ta tb a b
affineTraversal match set = dimap f g . _Right . _1
where
f ta = (\x -> (x,ta)) <$> match ta
g = id ||| uncurry set
traversal :: (forall f. Applicative f => (a -> f b) -> ta -> f tb) -> Traversal ta tb a b
traversal l = dimap f g . wander
where
f ta = TraversableFreeApplicativePStore (FreeApplicativePStore (flip l ta))
g (TraversableFreeApplicativePStore (FreeApplicativePStore fps)) = runIdentity (fps Identity)
sec :: ((a -> b) -> ta -> tb) -> SEC ta tb a b
sec l = dimap (PCont . flip l) (($ id) . pcont) . map
data PStore i j x = PStore { peek :: j -> x, pos :: i }
instance Functor (PStore i j) where
fmap f (PStore h i) = PStore (f . h) i
idPStore :: a -> PStore a b b
idPStore = PStore id
newtype PCont i j x = PCont { pcont :: (x -> j) -> i }
instance Functor (PCont i j) where
fmap f (PCont k) = PCont $ k . (. f)
newtype FreeApplicativePStore i j x = FreeApplicativePStore { runFreeApplicativePStore :: forall f. Applicative f => (i -> f j) -> f x }
instance Functor (FreeApplicativePStore i j) where
fmap f (FreeApplicativePStore fps) = FreeApplicativePStore $ (fmap f) . fps
instance Applicative (FreeApplicativePStore i j) where
pure x = FreeApplicativePStore $ const (pure x)
FreeApplicativePStore f <*> FreeApplicativePStore x = FreeApplicativePStore $ \op -> (f op) <*> (x op)
idFreeApplicativePStore :: a -> FreeApplicativePStore a b b
idFreeApplicativePStore a = FreeApplicativePStore ($ a)
newtype TraversableFreeApplicativePStore j x i = TraversableFreeApplicativePStore { getTraversableFreeApplicativePStore :: FreeApplicativePStore i j x }
instance Functor (TraversableFreeApplicativePStore j x) where
fmap = fmapDefault
instance Foldable (TraversableFreeApplicativePStore j x) where
foldMap = foldMapDefault
instance Traversable (TraversableFreeApplicativePStore j x) where
traverse f (TraversableFreeApplicativePStore (FreeApplicativePStore fps)) = map TraversableFreeApplicativePStore . getCompose $
fps (Compose . map idFreeApplicativePStore . f)