{-
This module contains the modified source code from polysemy-conc-0.7.0.0 package
under 'BSD-2-Clause-Patent'. So that part is only licensed under
'AGPL-3.0-or-later AND BSD-2-Clause-Patent', other part is licensed under
'AGPL-3.0-or-later'.
-}

-- -----BEGIN AGPL-3.0-or-later PART-----
-- Copyright (C) 2022 Hisaket VioletRed

{-|
License     : See the header comment of the source file of this module.
Maintainer  : hisaket@outlook.jp
Stability   : experimental
Portability : POSIX
-}

{-# LANGUAGE EmptyCase #-}

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use camelCase" #-}

module Polysemy.Scoped.Path.Internal where

import Polysemy ( Sem, InterpreterFor, Members )
import Polysemy.Internal.Union
    ( decomp, hoist, membership
    , Union (Union), Weaving (Weaving), ElemOf (Here, There)
    )
import Polysemy.Internal
    ( Sem (Sem, runSem), hoistSem, InterpreterFor, Members )
import Control.Category ((>>>))
import Polysemy.FS.Scoped.Internal.MembersProof ( MembersProof )
import Polysemy.Internal.Sing ( SList (SEnd, SCons), KnownList (singList) )
import Polysemy.Bundle ( Bundle (Bundle) )

-- | Bundle all effects of 'Sem' into a single 'Bundle'.
bundle :: Sem es a -> Sem (Bundle es ': r) a
bundle :: Sem es a -> Sem (Bundle es : r) a
bundle =
    (forall x.
 Union es (Sem es) x
 -> Union (Bundle es : r) (Sem (Bundle es : r)) x)
-> Sem es a -> Sem (Bundle es : r) a
forall (r :: EffectRow) (r' :: EffectRow) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem \(Union ElemOf e es
w (Weaving e (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem es (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins)) ->
        ElemOf (Bundle es) (Bundle es : r)
-> Weaving (Bundle es) (Sem (Bundle es : r)) x
-> Union (Bundle es : r) (Sem (Bundle es : r)) x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow)
       (mWoven :: * -> *) a.
ElemOf e r -> Weaving e mWoven a -> Union r mWoven a
Union ElemOf (Bundle es) (Bundle es : r)
forall k (r :: [k]) (e :: k) (r' :: [k]).
(r ~ (e : r')) =>
ElemOf e r
Here (Weaving (Bundle es) (Sem (Bundle es : r)) x
 -> Union (Bundle es : r) (Sem (Bundle es : r)) x)
-> Weaving (Bundle es) (Sem (Bundle es : r)) x
-> Union (Bundle es : r) (Sem (Bundle es : r)) x
forall a b. (a -> b) -> a -> b
$ Bundle es (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem (Bundle es : r) (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving (Bundle es) (Sem (Bundle es : r)) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (rInitial :: EffectRow) 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 es -> e (Sem rInitial) a -> Bundle es (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 es
w e (Sem rInitial) a
e) f ()
s (Sem es (f x) -> Sem (Bundle es : r) (f x)
forall (es :: EffectRow) a (r :: EffectRow).
Sem es a -> Sem (Bundle es : r) a
bundle (Sem es (f x) -> Sem (Bundle es : r) (f x))
-> (f (Sem rInitial x) -> Sem es (f x))
-> f (Sem rInitial x)
-> Sem (Bundle es : r) (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem es (f x)
forall x. f (Sem rInitial x) -> Sem es (f x)
wv) f a -> x
ex forall x. f x -> Maybe x
ins


subsumeBundle_id :: Sem (Bundle r ': r) a -> Sem r a
subsumeBundle_id :: Sem (Bundle r : r) a -> Sem r a
subsumeBundle_id = (forall (e :: (* -> *) -> * -> *). ElemOf e r -> ElemOf e r)
-> Sem (Bundle r : r) a -> Sem r a
forall (es :: EffectRow) (r :: EffectRow) a.
(forall (e :: (* -> *) -> * -> *). ElemOf e es -> ElemOf e r)
-> Sem (Bundle es : r) a -> Sem r a
subsumeBundleUsing forall a. a -> a
forall (e :: (* -> *) -> * -> *). ElemOf e r -> ElemOf e r
id

subsumeBundleUsing :: (∀e. ElemOf e es -> ElemOf e r) -> Sem (Bundle es ': r) a -> Sem r a
subsumeBundleUsing :: (forall (e :: (* -> *) -> * -> *). ElemOf e es -> ElemOf e r)
-> Sem (Bundle es : r) a -> Sem r a
subsumeBundleUsing forall (e :: (* -> *) -> * -> *). ElemOf e es -> ElemOf e r
i = (forall x.
 Union (Bundle es : r) (Sem (Bundle es : r)) x -> Union r (Sem r) x)
-> Sem (Bundle es : r) a -> Sem r a
forall (r :: EffectRow) (r' :: EffectRow) a.
(forall x. Union r (Sem r) x -> Union r' (Sem r') x)
-> Sem r a -> Sem r' a
hoistSem ((forall x.
  Union (Bundle es : r) (Sem (Bundle es : r)) x -> Union r (Sem r) x)
 -> Sem (Bundle es : r) a -> Sem r a)
-> (forall x.
    Union (Bundle es : r) (Sem (Bundle es : r)) x -> Union r (Sem r) x)
-> Sem (Bundle es : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Union (Bundle es : r) (Sem (Bundle es : r)) x
u -> (forall x. Sem (Bundle es : r) x -> Sem r x)
-> Union r (Sem (Bundle es : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist ((forall (e :: (* -> *) -> * -> *). ElemOf e es -> ElemOf e r)
-> Sem (Bundle es : r) x -> Sem r x
forall (es :: EffectRow) (r :: EffectRow) a.
(forall (e :: (* -> *) -> * -> *). ElemOf e es -> ElemOf e r)
-> Sem (Bundle es : r) a -> Sem r a
subsumeBundleUsing forall (e :: (* -> *) -> * -> *). ElemOf e es -> ElemOf e r
i) (Union r (Sem (Bundle es : r)) x -> Union r (Sem r) x)
-> Union r (Sem (Bundle es : r)) x -> Union r (Sem r) x
forall a b. (a -> b) -> a -> b
$ case Union (Bundle es : r) (Sem (Bundle es : r)) x
-> Either
     (Union r (Sem (Bundle es : r)) x)
     (Weaving (Bundle es) (Sem (Bundle es : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Bundle es : r) (Sem (Bundle es : r)) x
u of
    Right (Weaving (Bundle pr e) f ()
s forall x. f (Sem rInitial x) -> Sem (Bundle es : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
        ElemOf e r
-> Weaving e (Sem (Bundle es : r)) x
-> Union r (Sem (Bundle es : r)) x
forall (e :: (* -> *) -> * -> *) (r :: EffectRow)
       (mWoven :: * -> *) a.
ElemOf e r -> Weaving e mWoven a -> Union r mWoven a
Union (ElemOf e es -> ElemOf e r
forall (e :: (* -> *) -> * -> *). ElemOf e es -> ElemOf e r
i ElemOf e es
pr) (e (Sem rInitial) a
-> f ()
-> (forall x. f (Sem rInitial x) -> Sem (Bundle es : r) (f x))
-> (f a -> x)
-> (forall x. f x -> Maybe x)
-> Weaving e (Sem (Bundle es : r)) x
forall (f :: * -> *) (e :: (* -> *) -> * -> *)
       (rInitial :: EffectRow) 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 e (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem (Bundle es : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins)
    Left Union r (Sem (Bundle es : r)) x
g -> Union r (Sem (Bundle es : r)) x
g


unbundle :: Bundle '[e] m a -> e m a
unbundle :: Bundle '[e] m a -> e m a
unbundle = \case
    Bundle ElemOf e '[e]
Here e m a
e -> e m a
e m a
e
    Bundle (There ElemOf e r
es) e m a
e -> case ElemOf e r
es of

weakenBundle :: (Members es r, KnownList es) => Bundle es m a -> Bundle r m a
weakenBundle :: Bundle es m a -> Bundle r m a
weakenBundle (Bundle ElemOf e es
pr e m a
e) = ElemOf e r -> e m a -> Bundle r m 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 es -> ElemOf e r
forall (es :: EffectRow) (r :: EffectRow)
       (e :: (* -> *) -> * -> *).
(Members es r, KnownList es) =>
ElemOf e es -> ElemOf e r
weakenMembership ElemOf e es
pr) e m a
e


weakenMembership :: (Members es r, KnownList es) => ElemOf e es -> ElemOf e r
weakenMembership :: ElemOf e es -> ElemOf e r
weakenMembership = SList es -> ElemOf e es -> ElemOf e r
forall (es :: EffectRow) (r :: EffectRow)
       (e :: (* -> *) -> * -> *).
Members es r =>
SList es -> ElemOf e es -> ElemOf e r
weakenMembership' SList es
forall a (l :: [a]). KnownList l => SList l
singList

weakenMembership' :: Members es r => SList es -> ElemOf e es -> ElemOf e r
weakenMembership' :: SList es -> ElemOf e es -> ElemOf e r
weakenMembership' SList es
l ElemOf e es
pr = case SList es
l of
    SList es
SEnd -> case ElemOf e es
pr of
    SCons SList xs
xs -> case ElemOf e es
pr of
        ElemOf e es
Here -> ElemOf e r
forall (e :: (* -> *) -> * -> *) (r :: EffectRow).
Member e r =>
ElemOf e r
membership
        There ElemOf e r
pr' -> SList xs -> ElemOf e xs -> ElemOf e r
forall (es :: EffectRow) (r :: EffectRow)
       (e :: (* -> *) -> * -> *).
Members es r =>
SList es -> ElemOf e es -> ElemOf e r
weakenMembership' SList xs
xs ElemOf e xs
ElemOf e r
pr'

-- -----END AGPL-3.0-or-later PART-----
 
-- -----BEGIN AGPL-3.0-or-later AND BSD-2-Clause-Patent PART-----
{-
Copyright (c) 2020 Torsten Schmits
Copyright (c) 2022 Hisaket VioletRed
-}

data ScopedP path resource effect m a where
    Run :: ∀path resource effect m a. resource -> effect m a -> ScopedP path resource effect m a
    InScope :: ∀path resource effect m a. path -> (resource -> m a) -> ScopedP path resource effect m a

interpretH'
    :: (∀x. Weaving e (Sem (e : r)) x -> Sem r x)
    -> InterpreterFor e r
interpretH' :: (forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
interpretH' forall x. Weaving e (Sem (e : r)) x -> Sem r x
h (Sem forall (m :: * -> *).
Monad m =>
(forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a
m) =
    (forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
forall (r :: EffectRow) a.
(forall (m :: * -> *).
 Monad m =>
 (forall x. Union r (Sem r) x -> m x) -> m a)
-> Sem r a
Sem \forall x. Union r (Sem r) x -> m x
k -> (forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a
forall (m :: * -> *).
Monad m =>
(forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a
m ((forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a)
-> (forall x. Union (e : r) (Sem (e : r)) x -> m x) -> m a
forall a b. (a -> b) -> a -> b
$ Union (e : r) (Sem (e : r)) x
-> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp (Union (e : r) (Sem (e : r)) x
 -> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x))
-> (Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
    -> m x)
-> Union (e : r) (Sem (e : r)) x
-> m x
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
        Right Weaving e (Sem (e : r)) x
wav -> Sem r x -> (forall x. Union r (Sem r) x -> m x) -> m x
forall (r :: EffectRow) a.
Sem r a
-> forall (m :: * -> *).
   Monad m =>
   (forall x. Union r (Sem r) x -> m x) -> m a
runSem (Weaving e (Sem (e : r)) x -> Sem r x
forall x. Weaving e (Sem (e : r)) x -> Sem r x
h Weaving e (Sem (e : r)) x
wav) forall x. Union r (Sem r) x -> m x
k
        Left Union r (Sem (e : r)) x
g -> Union r (Sem r) x -> m x
forall x. Union r (Sem r) x -> m x
k (Union r (Sem r) x -> m x) -> Union r (Sem r) x -> m x
forall a b. (a -> b) -> a -> b
$ InterpreterFor e r -> Union r (Sem (e : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist ((forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
forall (e :: (* -> *) -> * -> *) (r :: EffectRow).
(forall x. Weaving e (Sem (e : r)) x -> Sem r x)
-> InterpreterFor e r
interpretH' forall x. Weaving e (Sem (e : r)) x -> Sem r x
h) Union r (Sem (e : r)) x
g


{-
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the
following conditions are met:

  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  disclaimer.
  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  disclaimer in the documentation and/or other materials provided with the distribution.

Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those
receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except
for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,
import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired
or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:

  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of
  contributors, in source or binary form) alone; or
  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such
  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to
  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.

Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this
license, whether expressly, by implication, estoppel or otherwise.

DISCLAIMER

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
-- -----END AGPL-3.0-or-later AND BSD-2-Clause-Patent PART-----