{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Profunctor.Optic.Fold0 (
Fold0
, fold0
, ixfold0
, failing
, toFold0
, fromFold0
, folded0
, withFold0
, withIxfold0
, (^?)
, preview
, preuse
, ixpreview
, ixpreviews
, tries
, tries_
, catches
, catches_
, handles
, handles_
, Fold0Rep(..)
, AFold0
, AIxfold0
, Pre(..)
, Strong(..)
, Choice(..)
) where
import Control.Applicative
import Control.Exception (Exception)
import Control.Monad ((<=<), void)
import Control.Monad.IO.Unlift
import Control.Monad.Reader as Reader hiding (lift)
import Control.Monad.State as State hiding (lift)
import Data.Foldable (Foldable, foldMap, traverse_)
import Data.Maybe
import Data.Monoid hiding (All(..), Any(..))
import Data.Prd (Prd(..), Min(..), Max(..))
import Data.Prd.Lattice (Lattice(..))
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Prism (right, just, async)
import Data.Profunctor.Optic.Traversal0 (ixtraversal0Vl, is)
import Data.Profunctor.Optic.Type
import Data.Profunctor.Optic.View (AView, to, from, withPrimView, view, cloneView)
import Data.Semiring (Semiring(..), Prod(..))
import qualified Control.Exception as Ex
import qualified Data.List.NonEmpty as NEL
import qualified Data.Prd as Prd
import qualified Data.Semiring as Rng
type AFold0 r s a = Optic' (Fold0Rep r) s a
type AIxfold0 r i s a = IndexedOptic' (Fold0Rep r) i s a
fold0 :: (s -> Maybe a) -> Fold0 s a
fold0 f = to (\s -> maybe (Left s) Right (f s)) . right'
{-# INLINE fold0 #-}
ixfold0 :: (s -> Maybe (i, a)) -> Ixfold0 i s a
ixfold0 g = ixtraversal0Vl (\point f s -> maybe (point s) (uncurry f) $ g s) . coercer
{-# INLINE ixfold0 #-}
infixl 3 `failing`
failing :: AFold0 a s a -> AFold0 a s a -> Fold0 s a
failing a b = fold0 $ \s -> maybe (preview b s) Just (preview a s)
{-# INLINE failing #-}
toFold0 :: View s (Maybe a) -> Fold0 s a
toFold0 = (. just)
{-# INLINE toFold0 #-}
fromFold0 :: AFold0 a s a -> View s (Maybe a)
fromFold0 = to . preview
{-# INLINE fromFold0 #-}
folded0 :: Fold0 (Maybe a) a
folded0 = fold0 id
{-# INLINE folded0 #-}
withFold0 :: Optic (Fold0Rep r) s t a b -> (a -> Maybe r) -> s -> Maybe r
withFold0 o = runFold0Rep #. o .# Fold0Rep
{-# INLINE withFold0 #-}
withIxfold0 :: AIxfold0 r i s a -> (i -> a -> Maybe r) -> i -> s -> Maybe r
withIxfold0 o f = curry $ withFold0 o (uncurry f)
{-# INLINE withIxfold0 #-}
infixl 8 ^?
(^?) :: s -> AFold0 a s a -> Maybe a
(^?) = flip preview
{-# INLINE (^?) #-}
preview :: MonadReader s m => AFold0 a s a -> m (Maybe a)
preview o = Reader.asks $ withFold0 o Just
{-# INLINE preview #-}
preuse :: MonadState s m => AFold0 a s a -> m (Maybe a)
preuse o = State.gets $ preview o
{-# INLINE preuse #-}
ixpreview :: Monoid i => AIxfold0 (i , a) i s a -> s -> Maybe (i , a)
ixpreview o = ixpreviews o (,)
{-# INLINE ixpreview #-}
ixpreviews :: Monoid i => AIxfold0 r i s a -> (i -> a -> r) -> s -> Maybe r
ixpreviews o f = withIxfold0 o (\i -> Just . f i) mempty
{-# INLINE ixpreviews #-}
tries :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m (Either e a)
tries o a = withRunInIO $ \run -> run (Right `liftM` a) `Ex.catch` \e ->
if is async e then throwM e else run $ maybe (throwM e) (return . Left) (preview o e)
{-# INLINE tries #-}
tries_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m (Maybe a)
tries_ o a = preview right `liftM` tries o a
{-# INLINE tries_ #-}
catches :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> (e -> m a) -> m a
catches o a ea = withRunInIO $ \run -> run a `Ex.catch` \e ->
if is async e then throwM e else run $ maybe (throwM e) ea (preview o e)
{-# INLINE catches #-}
catches_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m a -> m a
catches_ o x y = catches o x $ const y
{-# INLINE catches_ #-}
handles :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> (e -> m a) -> m a -> m a
handles o = flip $ catches o
{-# INLINE handles #-}
handles_ :: MonadUnliftIO m => Exception ex => AFold0 e ex e -> m a -> m a -> m a
handles_ o = flip $ catches_ o
{-# INLINE handles_ #-}
throwM :: MonadIO m => Exception e => e -> m a
throwM = liftIO . Ex.throwIO
{-# INLINE throwM #-}
newtype Fold0Rep r a b = Fold0Rep { runFold0Rep :: a -> Maybe r }
instance Functor (Fold0Rep r a) where
fmap _ (Fold0Rep p) = Fold0Rep p
instance Contravariant (Fold0Rep r a) where
contramap _ (Fold0Rep p) = Fold0Rep p
instance Profunctor (Fold0Rep r) where
dimap f _ (Fold0Rep p) = Fold0Rep (p . f)
instance Choice (Fold0Rep r) where
left' (Fold0Rep p) = Fold0Rep (either p (const Nothing))
right' (Fold0Rep p) = Fold0Rep (either (const Nothing) p)
instance Cochoice (Fold0Rep r) where
unleft (Fold0Rep k) = Fold0Rep (k . Left)
unright (Fold0Rep k) = Fold0Rep (k . Right)
instance Strong (Fold0Rep r) where
first' (Fold0Rep p) = Fold0Rep (p . fst)
second' (Fold0Rep p) = Fold0Rep (p . snd)
instance Sieve (Fold0Rep r) (Pre r) where
sieve = (Pre .) . runFold0Rep
instance Representable (Fold0Rep r) where
type Rep (Fold0Rep r) = Pre r
tabulate = Fold0Rep . (getPre .)
{-# INLINE tabulate #-}
newtype Pre a b = Pre { getPre :: Maybe a } deriving (Eq, Ord, Show)
instance Functor (Pre a) where fmap _ (Pre p) = Pre p
instance Contravariant (Pre a) where contramap _ (Pre p) = Pre p