#ifdef TRUSTWORTHY
#endif
module Control.Lens.Action.Reified where
import Control.Applicative
import Control.Arrow
import qualified Control.Category as Cat
import Control.Lens hiding ((<.>))
import Control.Monad
import Control.Monad.Reader.Class
import Data.Functor.Contravariant
import Data.Functor.Bind
import Data.Functor.Plus
import Data.Profunctor
import Data.Semigroup
import Control.Lens.Action
newtype ReifiedMonadicFold m s a = MonadicFold { runMonadicFold :: MonadicFold m s a }
instance Profunctor (ReifiedMonadicFold m) where
dimap f g l = MonadicFold (to f . runMonadicFold l . to g)
rmap g l = MonadicFold (runMonadicFold l . to g)
lmap f l = MonadicFold (to f . runMonadicFold l)
instance Strong (ReifiedMonadicFold m) where
first' l = MonadicFold $ \f (s,c) ->
phantom $ runMonadicFold l (dimap (flip (,) c) phantom f) s
second' l = MonadicFold $ \f (c,s) ->
phantom $ runMonadicFold l (dimap ((,) c) phantom f) s
instance Choice (ReifiedMonadicFold m) where
left' (MonadicFold l) = MonadicFold $
to tuplify.beside (folded.l.to Left) (folded.to Right)
where
tuplify (Left lval) = (Just lval,Nothing)
tuplify (Right rval) = (Nothing,Just rval)
instance Cat.Category (ReifiedMonadicFold m) where
id = MonadicFold id
l . r = MonadicFold (runMonadicFold r . runMonadicFold l)
instance Arrow (ReifiedMonadicFold m) where
arr f = MonadicFold (to f)
first = first'
second = second'
instance ArrowChoice (ReifiedMonadicFold m) where
left = left'
right = right'
instance ArrowApply (ReifiedMonadicFold m) where
app = MonadicFold $ \cHandler (argFold,b) ->
runMonadicFold (pure b >>> argFold) cHandler (argFold,b)
instance Functor (ReifiedMonadicFold m s) where
fmap f l = MonadicFold (runMonadicFold l.to f)
instance Apply (ReifiedMonadicFold m s) where
mf <.> ma = mf &&& ma >>> (MonadicFold $ to (uncurry ($)))
instance Applicative (ReifiedMonadicFold m s) where
pure a = MonadicFold $ folding $ \_ -> [a]
mf <*> ma = mf <.> ma
instance Alternative (ReifiedMonadicFold m s) where
empty = MonadicFold ignored
MonadicFold ma <|> MonadicFold mb = MonadicFold $ to (\x->(x,x)).beside ma mb
instance Bind (ReifiedMonadicFold m s) where
ma >>- f = ((ma >>^ f) &&& returnA) >>> app
instance Monad (ReifiedMonadicFold m s) where
return a = MonadicFold $ folding $ \_ -> [a]
ma >>= f = ((ma >>^ f) &&& returnA) >>> app
instance MonadReader s (ReifiedMonadicFold m s) where
ask = returnA
local f ma = f ^>> ma
instance MonadPlus (ReifiedMonadicFold m s) where
mzero = empty
mplus = (<|>)
instance Semigroup (ReifiedMonadicFold m s a) where
(<>) = (<|>)
instance Monoid (ReifiedMonadicFold m s a) where
mempty = MonadicFold ignored
mappend = (<|>)
instance Alt (ReifiedMonadicFold m s) where
(<!>) = (<|>)
instance Plus (ReifiedMonadicFold m s) where
zero = MonadicFold ignored