{-# OPTIONS_GHC -Wno-unused-foralls #-}

module Plutarch.TermCont (
  hashOpenTerm,
  TermCont (TermCont),
  runTermCont,
  unTermCont,
  tcont,
) where

import Data.Kind (Type)
import Data.String (fromString)
import Plutarch.Internal (
  Dig,
  PType,
  S,
  Term (Term),
  asRawTerm,
  getTerm,
  hashRawTerm,
  pgetConfig,
  tracingMode,
  pattern DetTracing,
 )
import Plutarch.Trace (ptraceError)

newtype TermCont :: forall (r :: PType). S -> Type -> Type where
  TermCont :: forall r s a. {forall (r :: PType) (s :: S) a.
TermCont @r s a -> (a -> Term s r) -> Term s r
runTermCont :: (a -> Term s r) -> Term s r} -> TermCont @r s a

unTermCont :: TermCont @a s (Term s a) -> Term s a
unTermCont :: forall (a :: PType) (s :: S). TermCont @a s (Term s a) -> Term s a
unTermCont TermCont @a s (Term s a)
t = forall (r :: PType) (s :: S) a.
TermCont @r s a -> (a -> Term s r) -> Term s r
runTermCont TermCont @a s (Term s a)
t forall a. a -> a
id

instance Functor (TermCont s) where
  fmap :: forall a b. (a -> b) -> TermCont @r s a -> TermCont @r s b
fmap a -> b
f (TermCont (a -> Term s r) -> Term s r
g) = forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont forall a b. (a -> b) -> a -> b
$ \b -> Term s r
h -> (a -> Term s r) -> Term s r
g (b -> Term s r
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative (TermCont s) where
  pure :: forall a. a -> TermCont @r s a
pure a
x = forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont forall a b. (a -> b) -> a -> b
$ \a -> Term s r
f -> a -> Term s r
f a
x
  TermCont @r s (a -> b)
x <*> :: forall a b.
TermCont @r s (a -> b) -> TermCont @r s a -> TermCont @r s b
<*> TermCont @r s a
y = do
    a -> b
x <- TermCont @r s (a -> b)
x
    a -> b
x forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TermCont @r s a
y

instance Monad (TermCont s) where
  (TermCont (a -> Term s r) -> Term s r
f) >>= :: forall a b.
TermCont @r s a -> (a -> TermCont @r s b) -> TermCont @r s b
>>= a -> TermCont @r s b
g = forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont forall a b. (a -> b) -> a -> b
$ \b -> Term s r
h ->
    (a -> Term s r) -> Term s r
f
      ( \a
x ->
          forall (r :: PType) (s :: S) a.
TermCont @r s a -> (a -> Term s r) -> Term s r
runTermCont (a -> TermCont @r s b
g a
x) b -> Term s r
h
      )

instance MonadFail (TermCont s) where
  fail :: forall a. String -> TermCont @r s a
fail String
s = forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont forall a b. (a -> b) -> a -> b
$ \a -> Term s r
_ ->
    forall (s :: S) (a :: PType). (Config -> Term s a) -> Term s a
pgetConfig \Config
c -> case Config -> TracingMode
tracingMode Config
c of
      TracingMode
DetTracing -> forall (s :: S) (a :: PType). Term s PString -> Term s a
ptraceError Term s PString
"Pattern matching failure in TermCont"
      TracingMode
_ -> forall (s :: S) (a :: PType). Term s PString -> Term s a
ptraceError forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
s

tcont :: ((a -> Term s r) -> Term s r) -> TermCont @r s a
tcont :: forall a (s :: S) (r :: PType).
((a -> Term s r) -> Term s r) -> TermCont @r s a
tcont = forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont

hashOpenTerm :: Term s a -> TermCont s Dig
hashOpenTerm :: forall {r :: PType} (s :: S) (a :: PType).
Term s a -> TermCont @r s Dig
hashOpenTerm Term s a
x = forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont forall a b. (a -> b) -> a -> b
$ \Dig -> Term s r
f -> forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term forall a b. (a -> b) -> a -> b
$ \Word64
i -> do
  TermResult
y <- forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
x Word64
i
  forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Dig -> Term s r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> Dig
hashRawTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm forall a b. (a -> b) -> a -> b
$ TermResult
y) Word64
i