module Control.Reference.Predefined where
import Control.Reference.Representation
import Control.Reference.Types
import Control.Reference.Generators
import Control.Reference.Combinators
import Control.Reference.Operators
import Control.Instances.Morph
import Control.Applicative
import Control.Monad
import Data.Ratio
import qualified Data.Text as Text
import Data.Complex
import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.State
import Control.Concurrent.MVar hiding (modifyMVarMasked_)
import Control.Concurrent.Chan
import Data.IORef
import Data.Either.Combinators
import Data.STRef
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error
import qualified Control.Exception as Ex
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)
atArg :: Eq a => a -> Simple Lens (a -> b) b
atArg a = lens ($ a) (\b f -> \x -> if a == x then b else f x)
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))
fileContent :: Simple IOLens FilePath (Maybe String)
fileContent
= reference (\fp -> morph (getFileCont fp))
(\cont fp -> morph (setFileCont fp cont) >> return fp)
(\trf fp -> morph (getFile fp) >>= \hcnt -> trf (fmap snd hcnt)
>>= morph . updateFileCont fp (fmap fst hcnt) >> return fp)
where getFileCont :: FilePath -> IO (Maybe String)
getFileCont fp = (Just <$> readFile fp)
`Ex.catch` \e -> if isDoesNotExistError e then return Nothing
else Ex.throw e
getFile :: FilePath -> IO (Maybe (Handle, String))
getFile fp = do h <- (Just <$> openFile fp ReadMode)
`Ex.catch` \e -> if isDoesNotExistError e then return Nothing
else Ex.throw e
case h of
Just handle -> do cont <- hGetContents handle
`Ex.catch` \e -> hClose handle >> Ex.throw (e :: Ex.SomeException)
return $ Just (handle, cont)
Nothing -> return Nothing
setFileCont :: FilePath -> Maybe String -> IO ()
setFileCont fp Nothing = removeFile fp
setFileCont fp (Just cont) = writeFile fp cont
updateFileCont :: FilePath -> Maybe Handle -> Maybe String -> IO ()
updateFileCont fp h Nothing = (just !| hClose) h >> removeFile fp
updateFileCont fp h (Just cont)
= Ex.bracket (openTempFile (takeDirectory fp) (takeFileName fp))
(\(tfp,th) -> hClose th >> (just !| hClose) h >> removeFile tfp)
(\(_,th) -> hPutStr th cont >> (just !| hClose) h >> hSeek th AbsoluteSeek 0
>> hGetContents th >>= writeFile fp)
mvar :: Simple IOLens (MVar a) a
mvar = rawReference
(\f mv -> pullBack $ withMVarMasked mv (sink . f))
(\newVal mv -> morph $ do empty <- isEmptyMVar mv
if empty then putMVar mv newVal
else swapMVar mv newVal >> return ()
return mv)
(\trf mv -> modifyMVarMasked_ mv trf >> return mv)
unusableOp unusableOp unusableOp
modifyMVarMasked_ :: (Monad m, Morph IO m, MorphControl IO m) => MVar a -> (a -> m a) -> m ()
modifyMVarMasked_ m io =
mask_ $ do
a <- morph (takeMVar m)
a' <- io a `onException` morph (putMVar m a)
morph (putMVar m a')
mask_ :: (MorphControl IO m) => m a -> m a
mask_ = pullBack . Ex.mask_ . sink
onException :: (MorphControl IO m) => m a -> m b -> m a
onException a b = pullBack $ Ex.onException (sink a) (sink b)
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)
whereOf :: (RefMonads w r, MonadPlus r)
=> (i -> Bool) -> (IndexedReference i w r MU MU s s a a) -> (IndexedReference i w r MU MU s s a a)
whereOf p iref i | p i = iref i
| otherwise = emptyRef