{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module PlutusTx.Test.Util.Apply (
  CompiledCodeFuncToHaskType,
  FinalType,
  compiledCodeToHaskUnsafe,
  compiledCodeToHask,
  ) where

import Prelude

import Flat (Flat)
import PlutusCore qualified as PLC
import PlutusCore.Pretty (Pretty, PrettyBy, PrettyConst, RenderContext)
import PlutusTx.Code

type family CompiledCodeFuncToHaskType t r where
  CompiledCodeFuncToHaskType (CompiledCodeIn uni fun (a -> b)) r =
    CompiledCodeIn uni fun a -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r
  CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) r = r

type family FinalType t where
  FinalType (a -> b) = FinalType b
  FinalType a = a

class CompiledCodeFuncToHask t r uni fun where
  compiledCodeToHask'
    :: (Either String (CompiledCodeIn uni fun (FinalType t)) -> r)
    -> Either String (CompiledCodeIn uni fun t)
    -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun t) r

instance {-# OVERLAPPING #-} ( PLC.Everywhere uni Flat
         , PLC.Everywhere uni PrettyConst
         , PLC.Closed uni
         , Flat fun
         , Pretty fun
         , PrettyBy RenderContext (PLC.SomeTypeIn uni)
         , CompiledCodeFuncToHask b r uni fun
         , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun (a -> b)) r
           ~ (CompiledCodeIn uni fun a -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r)
         ) =>
  CompiledCodeFuncToHask (a -> b) r uni fun where
  compiledCodeToHask' :: (Either String (CompiledCodeIn uni fun (FinalType (a -> b))) -> r)
-> Either String (CompiledCodeIn uni fun (a -> b))
-> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun (a -> b)) r
compiledCodeToHask' Either String (CompiledCodeIn uni fun (FinalType (a -> b))) -> r
cont Either String (CompiledCodeIn uni fun (a -> b))
f CompiledCodeIn uni fun a
a =
    forall t r (uni :: * -> *) fun.
CompiledCodeFuncToHask t r uni fun =>
(Either String (CompiledCodeIn uni fun (FinalType t)) -> r)
-> Either String (CompiledCodeIn uni fun t)
-> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun t) r
compiledCodeToHask' @b @r Either String (CompiledCodeIn uni fun (FinalType b)) -> r
Either String (CompiledCodeIn uni fun (FinalType (a -> b))) -> r
cont (Either String (CompiledCodeIn uni fun b)
 -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r)
-> Either String (CompiledCodeIn uni fun b)
-> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r
forall a b. (a -> b) -> a -> b
$ Either String (CompiledCodeIn uni fun (a -> b))
f Either String (CompiledCodeIn uni fun (a -> b))
-> (CompiledCodeIn uni fun (a -> b)
    -> Either String (CompiledCodeIn uni fun b))
-> Either String (CompiledCodeIn uni fun b)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CompiledCodeIn uni fun (a -> b)
 -> CompiledCodeIn uni fun a
 -> Either String (CompiledCodeIn uni fun b))
-> CompiledCodeIn uni fun a
-> CompiledCodeIn uni fun (a -> b)
-> Either String (CompiledCodeIn uni fun b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a
-> Either String (CompiledCodeIn uni fun b)
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun, Pretty fun,
 Everywhere uni PrettyConst,
 PrettyBy RenderContext (SomeTypeIn uni)) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a
-> Either String (CompiledCodeIn uni fun b)
applyCode CompiledCodeIn uni fun a
a

instance
  ( FinalType a ~ a
  , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) r ~ r
  ) => CompiledCodeFuncToHask a r uni fun where
  compiledCodeToHask' :: (Either String (CompiledCodeIn uni fun (FinalType a)) -> r)
-> Either String (CompiledCodeIn uni fun a)
-> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) r
compiledCodeToHask' = (Either String (CompiledCodeIn uni fun (FinalType a)) -> r)
-> Either String (CompiledCodeIn uni fun a)
-> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) r
(Either String (CompiledCodeIn uni fun (FinalType a)) -> r)
-> Either String (CompiledCodeIn uni fun (FinalType a)) -> r
forall a b. (a -> b) -> a -> b
($)

{- | Transform 'CompiledCode' function into a function in "Hask". This helps applying
arguments to already built script in a type safe manner. Example:
```hs
foo :: CompiledCode (Integer -> () -> Bool)
bar :: CompiledCode Integer
baz :: CompiledCode ()

compiledCodeToHask foo bar baz :: Either String (CompiledCode ())
```
-}
compiledCodeToHask
  :: forall uni fun a
   . CompiledCodeFuncToHask a (Either String (CompiledCodeIn uni fun (FinalType a))) uni fun
  => CompiledCodeIn uni fun a
  -> CompiledCodeFuncToHaskType
       (CompiledCodeIn uni fun a)
       (Either String (CompiledCodeIn uni fun (FinalType a)))
compiledCodeToHask :: forall (uni :: * -> *) fun a.
CompiledCodeFuncToHask
  a (Either String (CompiledCodeIn uni fun (FinalType a))) uni fun =>
CompiledCodeIn uni fun a
-> CompiledCodeFuncToHaskType
     (CompiledCodeIn uni fun a)
     (Either String (CompiledCodeIn uni fun (FinalType a)))
compiledCodeToHask =
  forall t r (uni :: * -> *) fun.
CompiledCodeFuncToHask t r uni fun =>
(Either String (CompiledCodeIn uni fun (FinalType t)) -> r)
-> Either String (CompiledCodeIn uni fun t)
-> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun t) r
compiledCodeToHask'
    @a @(Either String (CompiledCodeIn uni fun (FinalType a)))
    Either String (CompiledCodeIn uni fun (FinalType a))
-> Either String (CompiledCodeIn uni fun (FinalType a))
forall a. a -> a
id
    (Either String (CompiledCodeIn uni fun a)
 -> CompiledCodeFuncToHaskType
      (CompiledCodeIn uni fun a)
      (Either String (CompiledCodeIn uni fun (FinalType a))))
-> (CompiledCodeIn uni fun a
    -> Either String (CompiledCodeIn uni fun a))
-> CompiledCodeIn uni fun a
-> CompiledCodeFuncToHaskType
     (CompiledCodeIn uni fun a)
     (Either String (CompiledCodeIn uni fun (FinalType a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledCodeIn uni fun a
-> Either String (CompiledCodeIn uni fun a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Same as 'compiledCodeToHask' but is partial instead of returning `Either String`.
compiledCodeToHaskUnsafe
  :: forall uni fun a
   . CompiledCodeFuncToHask a (CompiledCodeIn uni fun (FinalType a)) uni fun
  => CompiledCodeIn uni fun a
  -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) (CompiledCodeIn uni fun (FinalType a))
compiledCodeToHaskUnsafe :: forall (uni :: * -> *) fun a.
CompiledCodeFuncToHask
  a (CompiledCodeIn uni fun (FinalType a)) uni fun =>
CompiledCodeIn uni fun a
-> CompiledCodeFuncToHaskType
     (CompiledCodeIn uni fun a) (CompiledCodeIn uni fun (FinalType a))
compiledCodeToHaskUnsafe =
  forall t r (uni :: * -> *) fun.
CompiledCodeFuncToHask t r uni fun =>
(Either String (CompiledCodeIn uni fun (FinalType t)) -> r)
-> Either String (CompiledCodeIn uni fun t)
-> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun t) r
compiledCodeToHask'
    @a @(CompiledCodeIn uni fun (FinalType a))
    ((String -> CompiledCodeIn uni fun (FinalType a))
-> (CompiledCodeIn uni fun (FinalType a)
    -> CompiledCodeIn uni fun (FinalType a))
-> Either String (CompiledCodeIn uni fun (FinalType a))
-> CompiledCodeIn uni fun (FinalType a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> CompiledCodeIn uni fun (FinalType a)
forall a. HasCallStack => String -> a
error CompiledCodeIn uni fun (FinalType a)
-> CompiledCodeIn uni fun (FinalType a)
forall a. a -> a
id)
    (Either String (CompiledCodeIn uni fun a)
 -> CompiledCodeFuncToHaskType
      (CompiledCodeIn uni fun a) (CompiledCodeIn uni fun (FinalType a)))
-> (CompiledCodeIn uni fun a
    -> Either String (CompiledCodeIn uni fun a))
-> CompiledCodeIn uni fun a
-> CompiledCodeFuncToHaskType
     (CompiledCodeIn uni fun a) (CompiledCodeIn uni fun (FinalType a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledCodeIn uni fun a
-> Either String (CompiledCodeIn uni fun a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure