rhiannon morris
add2eb400c
it now recovers from (most) errors and always returns a type, so that isSubSing doesn't have to recalculate it it already assumed the inputs had the same type. now it just leans on that assumption harder
139 lines
3.2 KiB
Idris
139 lines
3.2 KiB
Idris
module Quox.EffExtra
|
|
|
|
import public Control.Eff
|
|
|
|
import Quox.ST
|
|
import Data.IORef
|
|
|
|
|
|
export
|
|
localAt : (0 lbl : tag) -> Has (StateL lbl s) fs =>
|
|
(s -> s) -> Eff fs a -> Eff fs a
|
|
localAt lbl f act = do
|
|
old <- getAt lbl
|
|
modifyAt lbl f *> act <* putAt lbl old
|
|
|
|
export %inline
|
|
localAt_ : (0 lbl : tag) -> Has (StateL lbl s) fs =>
|
|
s -> Eff fs a -> Eff fs a
|
|
localAt_ lbl x = localAt lbl $ const x
|
|
|
|
export %inline
|
|
local : Has (State s) fs => (s -> s) -> Eff fs a -> Eff fs a
|
|
local = localAt ()
|
|
|
|
export %inline
|
|
local_ : Has (State s) fs => s -> Eff fs a -> Eff fs a
|
|
local_ = localAt_ ()
|
|
|
|
|
|
export %inline
|
|
getsAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> a) -> Eff fs a
|
|
getsAt lbl f = f <$> getAt lbl
|
|
|
|
export %inline
|
|
gets : Has (State s) fs => (s -> a) -> Eff fs a
|
|
gets = getsAt ()
|
|
|
|
|
|
export
|
|
handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a
|
|
handleStateIORef r Get = readIORef r
|
|
handleStateIORef r (Put s) = writeIORef r s
|
|
|
|
export
|
|
handleStateSTRef : HasST m => STRef s st -> StateL lbl st a -> m s a
|
|
handleStateSTRef r Get = readRef r
|
|
handleStateSTRef r (Put s) = writeRef r s
|
|
|
|
|
|
|
|
public export
|
|
data Length : List a -> Type where
|
|
Z : Length []
|
|
S : Length xs -> Length (x :: xs)
|
|
%builtin Natural Length
|
|
|
|
export
|
|
subsetWith : Length xs => (forall z. Has z xs -> Has z ys) ->
|
|
Subset xs ys
|
|
subsetWith @{Z} f = []
|
|
subsetWith @{S len} f = f Z :: subsetWith (f . S)
|
|
|
|
export
|
|
subsetSelf : Length xs => Subset xs xs
|
|
subsetSelf = subsetWith id
|
|
|
|
export
|
|
subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs)
|
|
subsetTail _ = subsetWith S
|
|
|
|
|
|
export
|
|
catchMaybeAt : (0 lbl : tag) -> (Has (ExceptL lbl e) fs, Length fs) =>
|
|
(e -> Eff fs a) -> Eff fs a -> Eff fs a
|
|
catchMaybeAt lbl hnd act =
|
|
catchAt lbl hnd $ lift @{subsetTail $ ExceptL lbl e} act
|
|
|
|
export %inline
|
|
catchMaybe : (Has (Except e) fs, Length fs) =>
|
|
(e -> Eff fs a) -> Eff fs a -> Eff fs a
|
|
catchMaybe = catchMaybeAt ()
|
|
|
|
export
|
|
wrapErrAt : (0 lbl : tag) -> (Has (ExceptL lbl e) fs, Length fs) =>
|
|
(e -> e) -> Eff fs a -> Eff fs a
|
|
wrapErrAt lbl wrap = catchMaybeAt lbl (\ex => throwAt lbl $ wrap ex)
|
|
|
|
export %inline
|
|
wrapErr : (Has (Except e) fs, Length fs) => (e -> e) -> Eff fs a -> Eff fs a
|
|
wrapErr = wrapErrAt ()
|
|
|
|
|
|
export
|
|
handleExcept : Functor m => (forall c. e -> m c) -> ExceptL lbl e a -> m a
|
|
handleExcept thr (Err e) = thr e
|
|
|
|
|
|
export
|
|
handleReaderConst : Applicative m => r -> ReaderL lbl r a -> m a
|
|
handleReaderConst x Ask = pure x
|
|
|
|
|
|
public export
|
|
record IOErr e a where
|
|
constructor IOE
|
|
fromIOErr : IO (Either e a)
|
|
|
|
export
|
|
Functor (IOErr e) where
|
|
map f (IOE e) = IOE $ map f <$> e
|
|
|
|
export
|
|
Applicative (IOErr e) where
|
|
pure x = IOE $ pure $ pure x
|
|
IOE f <*> IOE x = IOE [|f <*> x|]
|
|
|
|
export
|
|
Monad (IOErr e) where
|
|
IOE m >>= k = IOE $ do
|
|
case !m of
|
|
Left err => pure $ Left err
|
|
Right x => fromIOErr $ k x
|
|
|
|
export
|
|
MonadRec (IOErr e) where
|
|
tailRecM s (Access r) x k = IOE $ do
|
|
let IOE m = k s x
|
|
case !m of
|
|
Left err => pure $ Left err
|
|
Right (Cont s' p y) => fromIOErr $ tailRecM s' (r s' p) y k
|
|
Right (Done y) => pure $ Right y
|
|
|
|
export
|
|
HasIO (IOErr e) where
|
|
liftIO = IOE . map Right
|
|
|
|
export %inline
|
|
ioLeft : e -> IOErr e a
|
|
ioLeft = IOE . pure . Left
|