{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module PlutusTx.TH
  ( compile
  , compileUntyped
  , loadFromFile
  ) where

import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import PlutusTx.Code
import PlutusTx.Plugin.Utils

-- We do not use qualified import because the whole module contains off-chain code
import Control.Monad.IO.Class
import Data.ByteString qualified as BS
import Prelude

-- | Compile a quoted Haskell expression into a corresponding Plutus Core program.
compile :: TH.Code TH.Q a -> TH.Code TH.Q (CompiledCode a)
-- See Note [Typed TH]
compile :: forall a. Code Q a -> Code Q (CompiledCode a)
compile Code Q a
e = Q Exp -> Code Q (CompiledCode a)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
TH.unsafeCodeCoerce (Q Exp -> Code Q (CompiledCode a))
-> Q Exp -> Code Q (CompiledCode a)
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp
compileUntyped (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ TExp a -> Exp
forall a. TExp a -> Exp
TH.unType (TExp a -> Exp) -> Q (TExp a) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Code Q a -> Q (TExp a)
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode Code Q a
e

-- | Load a 'CompiledCode' from a file. Drop-in replacement for 'compile'.
loadFromFile :: FilePath -> TH.Code TH.Q (CompiledCode a)
loadFromFile :: forall a. FilePath -> Code Q (CompiledCode a)
loadFromFile FilePath
fp = Q (TExp (CompiledCode a)) -> Code Q (CompiledCode a)
forall a (m :: * -> *). m (TExp a) -> Code m a
TH.liftCode (Q (TExp (CompiledCode a)) -> Code Q (CompiledCode a))
-> Q (TExp (CompiledCode a)) -> Code Q (CompiledCode a)
forall a b. (a -> b) -> a -> b
$ do
  -- We don't have a 'Lift' instance for 'CompiledCode' (we could but it would be tedious),
  -- so we lift the bytestring and construct the value in the quote.
  ByteString
bs <- IO ByteString -> Q ByteString
forall a. IO a -> Q a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile FilePath
fp
  Code Q (CompiledCode a) -> Q (TExp (CompiledCode a))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode [||ByteString
-> Maybe ByteString -> CoverageIndex -> CompiledCodeIn uni fun a
forall (uni :: * -> *) fun a.
ByteString
-> Maybe ByteString -> CoverageIndex -> CompiledCodeIn uni fun a
SerializedCode a
bs Maybe a
forall a. Maybe a
Nothing a
forall a. Monoid a => a
mempty||]

{- Note [Typed TH]
It's nice to use typed TH! However, we sadly can't *quite* use it thoroughly, because we
want to make a type literal, and there's no way to do that properly with typed TH.

Moreover, we really want to create an expression with the precise form that we want,
so we can't isolate the badness much. So we pretty much just have to use 'unsafeTExpCoerce'
and assert that we know what we're doing.

This isn't so bad, since our plc function accepts an argument of any type, so that's always
going to typecheck, and the result is always a 'CompiledCode', so that's also fine.
-}

-- | Compile a quoted Haskell expression into a corresponding Plutus Core program.
compileUntyped :: TH.Q TH.Exp -> TH.Q TH.Exp
compileUntyped :: Q Exp -> Q Exp
compileUntyped Q Exp
e = do
  FilePath -> Q ()
TH.addCorePlugin FilePath
"Plinth.Plugin"
  -- See Note [Typed TH]
  [|plinthc $(Q Exp
e)|]