#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
#endif
module Control.Reference.Predefined where
import Control.Reference.Representation
import Control.Reference.Operators
import Control.Applicative
import Control.Monad
import qualified Data.Traversable as Trav
import Data.Ratio
import qualified Data.Text as Text
import Data.Complex
import Control.Monad.Trans.Control
import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.ST
import Control.Concurrent.MVar.Lifted
import Control.Concurrent.Chan
import Data.IORef
import Data.Either.Combinators
import Data.STRef
self :: Lens a b a b
self = reference return (const . return) id
emptyRef :: Simple RefPlus s a
emptyRef = reference (const mzero) (const return) (const return)
traverse :: (Trav.Traversable t) => Traversal (t a) (t b) a b
traverse = reference (morph . execWriter . Trav.mapM (tell . (:[])))
(Trav.mapM . const . return)
Trav.mapM
iso :: (a -> b) -> (b -> a) -> Simple Iso a b
iso f g = bireference (return . f) (\b _ -> return . g $ b) (\trf a -> trf (f a) >>= return . g )
(return . g) (\a _ -> return . f $ a) (\trf b -> trf (g b) >>= return . f )
iso' :: (a -> b) -> (a' -> b') -> (b -> a) -> (b' -> a') -> Iso a a' b b'
iso' f f' g g'
= bireference (return . f) (\b _ -> return . g' $ b) (\trf a -> trf (f a) >>= return . g' )
(return . g) (\a _ -> return . f' $ a) (\trf b -> trf (g b) >>= return . f' )
lens :: (s -> a) -> (b -> s -> t) -> Lens s t a b
lens get set = reference (return . get)
(\b -> return . set b )
(\f a -> f (get a) >>= \b -> return $ set b a)
partial :: (s -> Either t (a, b -> t)) -> Partial s t a b
partial access
= reference
(either (const $ morph Nothing) (return . fst) . access)
(\b -> return . either id (($b) . snd) . access)
(\f -> either return (\(a,set) -> f a >>= return . set) . access)
prism :: (a -> s) -> (b -> t) -> (s -> Either t a) -> (t -> Maybe b) -> Prism s t a b
prism back back' access access'
= bireference (either (const $ morph Nothing) return . access)
(\b -> return . either id (const $ (back' b)) . access)
(\f -> either return (f >=> return . back') . access)
(return . back)
(\t _ -> morph $ access' t)
(\f a -> f (back a) >>= morph . access')
simplePrism :: (a -> s) -> (s -> Maybe a) -> Prism s s a a
simplePrism back access = prism back back (\s -> maybe (Left s) Right (access s)) access
simplePartial :: (s -> Maybe (a, a -> s)) -> Partial s s a a
simplePartial access
= partial (\s -> maybe (Left s) Right (access s))
fromLens :: (forall f . Functor f => (a -> f b) -> s -> f t) -> Lens s t a b
fromLens l = reference (\s -> return (getConst $ l Const s))
(\b -> return . (runIdentity . l (\_ -> Identity b)))
l
fromTraversal :: (forall f . Applicative f => (a -> f b) -> s -> f t) -> Traversal s t a b
fromTraversal l = reference (morph . execWriter . l (\a -> tell [a] >> return undefined))
(\b -> return . (runIdentity . l (\_ -> Identity b)))
l
filtered :: (a -> Bool) -> Simple RefPlus a a
filtered p = reference (\s -> if p s then return s else mzero)
(\a s -> if p s then return a else return s)
(\f s -> if p s then f s else return s)
just :: Prism (Maybe a) (Maybe b) a b
just = prism Just Just (maybe (Left Nothing) Right) id
right :: Prism (Either a b) (Either a c) b c
right = prism Right Right (either (Left . Left) Right) rightToMaybe
left :: Prism (Either a c) (Either b c) a b
left = prism Left Left (either Right (Left . Right)) leftToMaybe
anyway :: Lens (Either a a) (Either b b) a b
anyway = reference (either return return)
(\b -> return . mapBoth (const b) (const b))
(\f -> either (f >=> return . Left) (f >=> return . Right))
both :: Traversal (a,a) (b,b) a b
both = reference (\(x,y) -> morph [x,y])
(\v -> return . const (v,v))
(\f (x,y) -> (,) <$> f x <*> f y)
atHead :: Simple Lens [a] (Maybe a)
atHead = lens (\case [] -> Nothing; x:_ -> Just x)
(\case Nothing -> drop 1;
Just v -> \case [] -> [v]
_:xs -> v:xs)
headElem :: Simple Partial [a] a
headElem = atHead & just
_tail :: Simple Partial [a] [a]
_tail = simplePartial (\case [] -> Nothing; x:xs -> Just (xs,(x:)))
dropped :: Int -> Simple Partial [a] [a]
dropped 0 = self
dropped i = _tail & dropped (i1)
view :: Iso [a] [b] (Maybe (a,[a])) (Maybe (b,[b]))
view = iso' to to from from
where to :: [x] -> Maybe (x,[x])
to [] = Nothing
to (x:xs) = Just (x,xs)
from :: Maybe (x,[x]) -> [x]
from Nothing = []
from (Just (x,xs)) = x:xs
text :: Simple Iso String Text.Text
text = iso Text.pack Text.unpack
reversed :: Iso [a] [b] [a] [b]
reversed = iso' reverse reverse reverse reverse
_numerator :: Integral a => Simple Lens (Ratio a) a
_numerator = lens numerator (\num' r -> num' % denominator r)
_denominator :: Integral a => Simple Lens (Ratio a) a
_denominator = lens denominator (\denom' r -> numerator r % denom')
_realPart :: RealFloat a => Simple Lens (Complex a) a
_realPart = lens realPart (\real' c -> real' :+ imagPart c)
_imagPart :: RealFloat a => Simple Lens (Complex a) a
_imagPart = lens imagPart (\imag' c -> realPart c :+ imag')
_polar :: RealFloat a => Simple Lens (Complex a) (a, a)
_polar = iso polar (uncurry mkPolar)
data Console = Console
consoleLine :: Simple IOLens Console String
consoleLine
= reference (const (morph getLine))
(\str -> const (morph (putStrLn str) >> return Console))
(\f -> const (morph getLine >>= f
>>= morph . putStrLn
>> return Console))
mvar :: Simple IOLens (MVar a) a
mvar = rawReference
(flip withMVarMasked)
(\newVal mv -> do empty <- isEmptyMVar mv
if empty then putMVar mv newVal
else swapMVar mv newVal >> return ()
return mv)
(\trf mv -> modifyMVarMasked_ mv trf >> return mv)
(\_ _ -> MU) (\_ _ -> MU) (\_ _ -> MU)
chan :: Simple IOLens (Chan a) a
chan = reference (morph . readChan)
(\a ch -> morph (writeChan ch a) >> return ch)
(\trf ch -> morph (readChan ch) >>= trf
>>= morph . writeChan ch >> return ch)
ioref :: Simple IOLens (IORef a) a
ioref = reference (morph . readIORef)
(\v ior -> morph (atomicWriteIORef ior v) >> return ior)
(\trf ior -> morph (readIORef ior)
>>= trf >>= morph . writeIORef ior >> return ior)
state :: forall s m a . Monad m => Simple (StateLens s m) a s
state = reference (morph . const get') (\a s -> morph (put' a) >> return s)
(\trf s -> (morph get' >>= trf >> return s))
where put' = put :: s -> StateT s m ()
get' = get :: StateT s m s
stRef :: Simple (STLens s) (STRef s a) a
stRef = reference (morph . readSTRef)
(\newVal ref -> morph $ writeSTRef ref newVal >> return ref)
(\trf ref -> morph (readSTRef ref) >>= trf
>>= morph . writeSTRef ref >> return ref)