{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeApplications #-}
module PlutusTx.TH (
    compile,
    compileUntyped,
    loadFromFile) where

import Data.Proxy
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
"PlutusTx.Plugin"
    Loc
loc <- Q Loc
TH.location
    let locStr :: FilePath
locStr = Loc -> FilePath
forall a. Ppr a => a -> FilePath
TH.pprint Loc
loc
    -- See Note [Typed TH]
    [| plc (Proxy :: Proxy $(Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
TH.litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Q TyLit
forall (m :: * -> *). Quote m => FilePath -> m TyLit
TH.strTyLit FilePath
locStr)) $(Q Exp
e) |]