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

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

import Data.Kind (Type)
import Data.String (fromString)
import Plutarch.Internal.Term (
  Config (Tracing),
  Dig,
  PType,
  S,
  Term (Term),
  TracingMode (DetTracing),
  asRawTerm,
  getTerm,
  hashRawTerm,
  pgetConfig,
 )
import Plutarch.Trace (ptraceInfoError)

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 = TermCont @a s (Term s a) -> (Term s a -> Term s a) -> Term s a
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 Term s a -> Term s a
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) = ((b -> Term s r) -> Term s r) -> TermCont @r s b
forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont (((b -> Term s r) -> Term s r) -> TermCont @r s b)
-> ((b -> Term s r) -> Term s r) -> TermCont @r s b
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 (b -> Term s r) -> (a -> b) -> a -> Term s r
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 = ((a -> Term s r) -> Term s r) -> TermCont @r s a
forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont (((a -> Term s r) -> Term s r) -> TermCont @r s a)
-> ((a -> Term s r) -> Term s r) -> TermCont @r s a
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 (a -> b) -> TermCont @r s a -> TermCont @r s b
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 = ((b -> Term s r) -> Term s r) -> TermCont @r s b
forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont (((b -> Term s r) -> Term s r) -> TermCont @r s b)
-> ((b -> Term s r) -> Term s r) -> TermCont @r s b
forall a b. (a -> b) -> a -> b
$ \b -> Term s r
h ->
    (a -> Term s r) -> Term s r
f
      ( \a
x ->
          TermCont @r s b -> (b -> Term s r) -> Term s r
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 = ((a -> Term s r) -> Term s r) -> TermCont @r s a
forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont (((a -> Term s r) -> Term s r) -> TermCont @r s a)
-> ((a -> Term s r) -> Term s r) -> TermCont @r s a
forall a b. (a -> b) -> a -> b
$ \a -> Term s r
_ ->
    (Config -> Term s r) -> Term s r
forall (s :: S) (a :: PType). (Config -> Term s a) -> Term s a
pgetConfig ((Config -> Term s r) -> Term s r)
-> (Config -> Term s r) -> Term s r
forall a b. (a -> b) -> a -> b
$ \case
      -- Note: This currently works because DetTracing is the most specific
      -- tracing mode.
      Tracing LogLevel
_ TracingMode
DetTracing -> Term s PString -> Term s r
forall (a :: PType) (s :: S). Term s PString -> Term s a
ptraceInfoError Term s PString
"Pattern matching failure in TermCont"
      Config
_ -> Term s PString -> Term s r
forall (a :: PType) (s :: S). Term s PString -> Term s a
ptraceInfoError (Term s PString -> Term s r) -> Term s PString -> Term s r
forall a b. (a -> b) -> a -> b
$ String -> Term s PString
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 = ((a -> Term s r) -> Term s r) -> TermCont @r s a
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 = ((Dig -> Term s r) -> Term s r) -> TermCont @r s Dig
forall (r :: PType) (s :: S) a.
((a -> Term s r) -> Term s r) -> TermCont @r s a
TermCont (((Dig -> Term s r) -> Term s r) -> TermCont @r s Dig)
-> ((Dig -> Term s r) -> Term s r) -> TermCont @r s Dig
forall a b. (a -> b) -> a -> b
$ \Dig -> Term s r
f -> (Word64 -> TermMonad TermResult) -> Term s r
forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term ((Word64 -> TermMonad TermResult) -> Term s r)
-> (Word64 -> TermMonad TermResult) -> Term s r
forall a b. (a -> b) -> a -> b
$ \Word64
i -> do
  TermResult
y <- Term s a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
x Word64
i
  Term s r -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Dig -> Term s r
f (Dig -> Term s r) -> (TermResult -> Dig) -> TermResult -> Term s r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> Dig
hashRawTerm (RawTerm -> Dig) -> (TermResult -> RawTerm) -> TermResult -> Dig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm (TermResult -> Term s r) -> TermResult -> Term s r
forall a b. (a -> b) -> a -> b
$ TermResult
y) Word64
i