module Polysemy.FS.Scoped.Internal where
import Polysemy
( Sem, embed, Embed, InterpretersFor, Members, rewrite )
import Polysemy.Internal.Kind ( Append )
import Polysemy.Bundle ( runBundle, Bundle (Bundle) )
import Polysemy.Internal.Sing
( SList (SEnd, SCons), KnownList (singList) )
import Polysemy.Internal.Union
( decomp
, extendMembershipLeft
, hoist
, membership
, ElemOf
, Union(Union)
, Weaving(Weaving)
)
import Polysemy.Internal
( Sem, Append, embed, hoistSem, Embed, InterpretersFor, Members )
import Polysemy.Resource ( bracket, Resource )
import qualified System.IO as IO
import Polysemy.Path ( toFilePath, Path, File )
import Polysemy.Scoped.Path ( ScopedP, runScopedP )
import Polysemy.FS.Scoped.Internal.MembersProof
( MembersProof (MembersProof), membersProof, membersProofId )
newtype ScopedFile mode es b handle m a =
ScopedFile { ScopedFile mode es b handle m a
-> ScopedP (Path b File) handle (Bundle es) m a
unScopedFile :: ScopedP (Path b File) handle (Bundle es) m a }
scopedFileToIO
:: (Members '[Embed IO, Resource] r, KnownList es)
=> (FilePath -> IO.IOMode -> IO IO.Handle)
-> IO.IOMode
-> (IO.Handle -> InterpretersFor es r)
-> (∀handle'. Sem (ScopedFile mode es b handle' ': r) a)
-> Sem r a
scopedFileToIO :: (FilePath -> IOMode -> IO Handle)
-> IOMode
-> (Handle -> InterpretersFor es r)
-> (forall handle'. Sem (ScopedFile mode es b handle' : r) a)
-> Sem r a
scopedFileToIO FilePath -> IOMode -> IO Handle
openFile IOMode
mode =
(forall x. Path b File -> (Handle -> Sem r x) -> Sem r x)
-> (Handle -> InterpretersFor es r)
-> (forall handle'. Sem (ScopedFile mode es b handle' : r) a)
-> Sem r a
forall k (es :: [(* -> *) -> * -> *]) b handle
(r :: [(* -> *) -> * -> *]) (mode :: k) a.
KnownList es =>
(forall x. Path b File -> (handle -> Sem r x) -> Sem r x)
-> (handle -> InterpretersFor es r)
-> (forall handle'. Sem (ScopedFile mode es b handle' : r) a)
-> Sem r a
runScopedFile
(\Path b File
path -> Sem r Handle
-> (Handle -> Sem r ()) -> (Handle -> Sem r x) -> Sem r x
forall (r :: [(* -> *) -> * -> *]) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket (IO Handle -> Sem r Handle
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Handle -> Sem r Handle) -> IO Handle -> Sem r Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFile (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
path) IOMode
mode) (IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> (Handle -> IO ()) -> Handle -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
IO.hClose))
runScopedFile
:: KnownList es
=> (∀x. Path b File -> (handle -> Sem r x) -> Sem r x)
-> (handle -> InterpretersFor es r)
-> (∀handle'. Sem (ScopedFile mode es b handle' ': r) a)
-> Sem r a
runScopedFile :: (forall x. Path b File -> (handle -> Sem r x) -> Sem r x)
-> (handle -> InterpretersFor es r)
-> (forall handle'. Sem (ScopedFile mode es b handle' : r) a)
-> Sem r a
runScopedFile forall x. Path b File -> (handle -> Sem r x) -> Sem r x
acquire handle -> InterpretersFor es r
interpret forall handle'. Sem (ScopedFile mode es b handle' : r) a
m =
(forall x. Path b File -> (handle -> Sem r x) -> Sem r x)
-> (handle -> InterpreterFor (Bundle es) r)
-> InterpreterFor (ScopedP (Path b File) handle (Bundle es)) r
forall path resource (effect :: (* -> *) -> * -> *)
(r :: [(* -> *) -> * -> *]).
(forall x. path -> (resource -> Sem r x) -> Sem r x)
-> (resource -> InterpreterFor effect r)
-> InterpreterFor (ScopedP path resource effect) r
runScopedP forall x. Path b File -> (handle -> Sem r x) -> Sem r x
acquire (\handle
h -> handle -> InterpretersFor es r
interpret handle
h (Sem (Append es r) a -> Sem r a)
-> (Sem (Bundle es : r) a -> Sem (Append es r) a)
-> Sem (Bundle es : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Bundle es : r) a -> Sem (Append es r) a
forall (r' :: [(* -> *) -> * -> *]) (r :: [(* -> *) -> * -> *]) a.
KnownList r' =>
Sem (Bundle r' : r) a -> Sem (Append r' r) a
runBundle) (Sem (ScopedP (Path b File) handle (Bundle es) : r) a -> Sem r a)
-> Sem (ScopedP (Path b File) handle (Bundle es) : r) a -> Sem r a
forall a b. (a -> b) -> a -> b
$ (forall (rInitial :: [(* -> *) -> * -> *]) x.
ScopedFile mode es b handle (Sem rInitial) x
-> ScopedP (Path b File) handle (Bundle es) (Sem rInitial) x)
-> Sem (ScopedFile mode es b handle : r) a
-> Sem (ScopedP (Path b File) handle (Bundle es) : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
(r :: [(* -> *) -> * -> *]) a.
(forall (rInitial :: [(* -> *) -> * -> *]) x.
e1 (Sem rInitial) x -> e2 (Sem rInitial) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
rewrite forall (rInitial :: [(* -> *) -> * -> *]) x.
ScopedFile mode es b handle (Sem rInitial) x
-> ScopedP (Path b File) handle (Bundle es) (Sem rInitial) x
forall k (mode :: k) k (es :: [(k -> *) -> k -> *]) b handle
(m :: k -> *) (a :: k).
ScopedFile mode es b handle m a
-> ScopedP (Path b File) handle (Bundle es) m a
unScopedFile Sem (ScopedFile mode es b handle : r) a
forall handle'. Sem (ScopedFile mode es b handle' : r) a
m
seekToBegin :: IO.Handle -> IO ()
seekToBegin :: Handle -> IO ()
seekToBegin Handle
h = Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
h SeekMode
IO.AbsoluteSeek Integer
0
seekToEnd :: IO.Handle -> IO ()
seekToEnd :: Handle -> IO ()
seekToEnd Handle
h = Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
h SeekMode
IO.SeekFromEnd Integer
0
sendBundle_
:: ∀es r a
. KnownList es
=> Sem (Append es (Bundle es ': r)) a
-> Sem (Bundle es ': r) a
sendBundle_ :: Sem (Append es (Bundle es : r)) a -> Sem (Bundle es : r) a
sendBundle_ = SList es
-> MembersProof es es
-> Sem (Append es (Bundle es : r)) a
-> Sem (Bundle es : r) a
forall (l :: [(* -> *) -> * -> *]) (es :: [(* -> *) -> * -> *])
(r :: [(* -> *) -> * -> *]) a.
SList l
-> MembersProof l es
-> Sem (Append l (Bundle es : r)) a
-> Sem (Bundle es : r) a
sendBundleSListUsingProof SList es
es (MembersProof es es
-> Sem (Append es (Bundle es : r)) a -> Sem (Bundle es : r) a)
-> MembersProof es es
-> Sem (Append es (Bundle es : r)) a
-> Sem (Bundle es : r) a
forall a b. (a -> b) -> a -> b
$ SList es -> MembersProof es es
forall (l :: [(* -> *) -> * -> *]). SList l -> MembersProof l l
membersProofId SList es
es
where es :: SList es
es = KnownList es => SList es
forall a (l :: [a]). KnownList l => SList l
singList @es
sendBundleSList
:: Members l es
=> SList l
-> Sem (Append l (Bundle es ': r)) a
-> Sem (Bundle es ': r) a
sendBundleSList :: SList l
-> Sem (Append l (Bundle es : r)) a -> Sem (Bundle es : r) a
sendBundleSList SList l
l = SList l
-> MembersProof l es
-> Sem (Append l (Bundle es : r)) a
-> Sem (Bundle es : r) a
forall (l :: [(* -> *) -> * -> *]) (es :: [(* -> *) -> * -> *])
(r :: [(* -> *) -> * -> *]) a.
SList l
-> MembersProof l es
-> Sem (Append l (Bundle es : r)) a
-> Sem (Bundle es : r) a
sendBundleSListUsingProof SList l
l (MembersProof l es
-> Sem (Append l (Bundle es : r)) a -> Sem (Bundle es : r) a)
-> MembersProof l es
-> Sem (Append l (Bundle es : r)) a
-> Sem (Bundle es : r) a
forall a b. (a -> b) -> a -> b
$ SList l -> MembersProof l es
forall (es :: [(* -> *) -> * -> *]) (r :: [(* -> *) -> * -> *]).
Members es r =>
SList es -> MembersProof es r
membersProof SList l
l
sendBundleSListUsingProof
:: ∀l es r a
. SList l
-> MembersProof l es
-> Sem (Append l (Bundle es ': r)) a
-> Sem (Bundle es ': r) a
sendBundleSListUsingProof :: SList l
-> MembersProof l es
-> Sem (Append l (Bundle es : r)) a
-> Sem (Bundle es : r) a
sendBundleSListUsingProof = \case
SList l
SEnd -> (Sem (Bundle es : r) a -> Sem (Bundle es : r) a)
-> MembersProof l es
-> Sem (Bundle es : r) a
-> Sem (Bundle es : r) a
forall a b. a -> b -> a
const Sem (Bundle es : r) a -> Sem (Bundle es : r) a
forall a. a -> a
id
SCons SList xs
l ->
\(MembersProof ElemOf e es
pr MembersProof es es
prs) ->
SList xs
-> MembersProof xs es
-> Sem (Append xs (Bundle es : r)) a
-> Sem (Bundle es : r) a
forall (l :: [(* -> *) -> * -> *]) (es :: [(* -> *) -> * -> *])
(r :: [(* -> *) -> * -> *]) a.
SList l
-> MembersProof l es
-> Sem (Append l (Bundle es : r)) a
-> Sem (Bundle es : r) a
sendBundleSListUsingProof SList xs
l MembersProof xs es
MembersProof es es
prs
(Sem (Append xs (Bundle es : r)) a -> Sem (Bundle es : r) a)
-> (Sem (e : Append xs (Bundle es : r)) a
-> Sem (Append xs (Bundle es : r)) a)
-> Sem (e : Append xs (Bundle es : r)) a
-> Sem (Bundle es : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElemOf e es
-> ElemOf (Bundle es) (Append xs (Bundle es : r))
-> Sem (e : Append xs (Bundle es : r)) a
-> Sem (Append xs (Bundle es : r)) a
forall (e :: (* -> *) -> * -> *) (r' :: [(* -> *) -> * -> *])
(r :: [(* -> *) -> * -> *]) a.
ElemOf e r' -> ElemOf (Bundle r') r -> Sem (e : r) a -> Sem r a
sendBundleUsing ElemOf e es
pr
(SList xs
-> ElemOf (Bundle es) (Bundle es : r)
-> ElemOf (Bundle es) (Append xs (Bundle es : r))
forall a (l :: [a]) (r :: [a]) (e :: a).
SList l -> ElemOf e r -> ElemOf e (Append l r)
extendMembershipLeft @_ @(Bundle es ': r) SList xs
l ElemOf (Bundle es) (Bundle es : r)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]).
Member e r =>
ElemOf e r
membership)
sendBundleUsing :: ElemOf e r' -> ElemOf (Bundle r') r -> Sem (e ': r) a -> Sem r a
sendBundleUsing :: ElemOf e r' -> ElemOf (Bundle r') r -> Sem (e : r) a -> Sem r a
sendBundleUsing ElemOf e r'
prE ElemOf (Bundle r') r
prBundle =
(forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
-> Sem (e : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) (r' :: [(* -> *) -> * -> *]) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem ((forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
-> Sem (e : r) a -> Sem r a)
-> (forall x. Union (e : r) (Sem (e : r)) x -> Union r (Sem r) x)
-> Sem (e : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Union (e : r) (Sem (e : r)) x
u -> case Union (e : r) (Sem (e : r)) x
-> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
(m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (e : r) (Sem (e : r)) x
u of
Right (Weaving e (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
ElemOf (Bundle r') r
-> Weaving (Bundle r') (Sem r) x -> Union r (Sem r) x
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
(mWoven :: * -> *) a.
ElemOf e r -> Weaving e mWoven a -> Union r mWoven a
Union ElemOf (Bundle r') r
prBundle (Weaving (Bundle r') (Sem r) x -> Union r (Sem r) x)
-> Weaving (Bundle r') (Sem r) x -> Union r (Sem r) x
forall a b. (a -> b) -> a -> b
$
Bundle r' (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem r (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving (Bundle r') (Sem r) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
(rInitial :: [(* -> *) -> * -> *]) a resultType (mAfter :: * -> *).
Functor f =>
e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> mAfter (f x))
-> (f a -> resultType)
-> (forall x. f x -> Maybe x)
-> Weaving e mAfter resultType
Weaving (ElemOf e r' -> e (Sem rInitial) a -> Bundle r' (Sem rInitial) a
forall k k1 (e :: k -> k1 -> *) (r :: [k -> k1 -> *]) (m :: k)
(a :: k1).
ElemOf e r -> e m a -> Bundle r m a
Bundle ElemOf e r'
prE e (Sem rInitial) a
e) f ()
s (ElemOf e r'
-> ElemOf (Bundle r') r -> Sem (e : r) (f x) -> Sem r (f x)
forall (e :: (* -> *) -> * -> *) (r' :: [(* -> *) -> * -> *])
(r :: [(* -> *) -> * -> *]) a.
ElemOf e r' -> ElemOf (Bundle r') r -> Sem (e : r) a -> Sem r a
sendBundleUsing ElemOf e r'
prE ElemOf (Bundle r') r
prBundle (Sem (e : r) (f x) -> Sem r (f x))
-> (f (Sem rInitial x) -> Sem (e : r) (f x))
-> f (Sem rInitial x)
-> Sem r (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem (e : r) (f x)
forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv) f a -> x
ex forall x. f x -> Maybe x
ins
Left Union r (Sem (e : r)) x
g -> (forall x. Sem (e : r) x -> Sem r x)
-> Union r (Sem (e : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist (ElemOf e r' -> ElemOf (Bundle r') r -> Sem (e : r) x -> Sem r x
forall (e :: (* -> *) -> * -> *) (r' :: [(* -> *) -> * -> *])
(r :: [(* -> *) -> * -> *]) a.
ElemOf e r' -> ElemOf (Bundle r') r -> Sem (e : r) a -> Sem r a
sendBundleUsing ElemOf e r'
prE ElemOf (Bundle r') r
prBundle) Union r (Sem (e : r)) x
g
{-# INLINE sendBundleUsing #-}