{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE FunctionalDependencies   #-}
{-# LANGUAGE MultiParamTypeClasses    #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE UndecidableInstances     #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}

module PlutusTx.Builtins.Class where

import Data.ByteString (ByteString)
import PlutusTx.Builtins.Internal

import Data.String (IsString (..))
import Data.Text (Text, pack)

import GHC.Magic qualified as Magic
import PlutusTx.Base (const, id, ($))
import PlutusTx.Bool (Bool (..))
import PlutusTx.Integer (Integer)
import Prelude qualified as Haskell (String)

{- Note [Fundeps versus type families in To/FromBuiltin]
We could use a type family here to get the builtin representation of a type. After all, it's
entirely determined by the Haskell type.

However, this is harder for the plugin to deal with. It's okay to have a type variable
for the representation type that needs to be instantiated later, but it's *not* okay to
have an irreducible type application on a type variable. So fundeps are much nicer here.
-}

{-|
A class witnessing the ability to convert from the builtin representation to the Haskell representation.
-}
class FromBuiltin arep a | arep -> a where
    fromBuiltin :: arep -> a

{-|
A class witnessing the ability to convert from the Haskell representation to the builtin representation.
-}
class ToBuiltin a arep | a -> arep where
    toBuiltin :: a -> arep

instance FromBuiltin BuiltinInteger Integer where
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinInteger -> BuiltinInteger
fromBuiltin = BuiltinInteger -> BuiltinInteger
forall a. a -> a
id
instance ToBuiltin Integer BuiltinInteger where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: BuiltinInteger -> BuiltinInteger
toBuiltin = BuiltinInteger -> BuiltinInteger
forall a. a -> a
id

instance FromBuiltin BuiltinBool Bool where
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinBool -> Bool
fromBuiltin BuiltinBool
b = BuiltinBool -> Bool -> Bool -> Bool
forall a. BuiltinBool -> a -> a -> a
ifThenElse BuiltinBool
b Bool
True Bool
False
instance ToBuiltin Bool BuiltinBool where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: Bool -> BuiltinBool
toBuiltin Bool
b = if Bool
b then BuiltinBool
true else BuiltinBool
false

{- Note [Strict conversions to/from unit]
Converting to/from unit *should* be straightforward: just ``const ()`.`
*But* GHC is very good at optimizing this, and we sometimes use unit
where side effects matter, e.g. as the result of `trace`. So GHC will
tend to turn `fromBuiltin (trace s)` into `()`, which is wrong.

So we want our conversions to/from unit to be strict in Haskell. This
means we need to case pointlessly on the argument, which means we need
case on unit (`chooseUnit`) as a builtin. But then it all works okay.
-}

instance FromBuiltin BuiltinUnit () where
    -- See Note [Strict conversions to/from unit]
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinUnit -> ()
fromBuiltin BuiltinUnit
u = BuiltinUnit -> () -> ()
forall a. BuiltinUnit -> a -> a
chooseUnit BuiltinUnit
u ()
instance ToBuiltin () BuiltinUnit where
    -- See Note [Strict conversions to/from unit]
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: () -> BuiltinUnit
toBuiltin ()
x = case ()
x of () -> BuiltinUnit
unitval

instance FromBuiltin BuiltinByteString ByteString where
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinByteString -> ByteString
fromBuiltin (BuiltinByteString ByteString
b) = ByteString
b
instance ToBuiltin ByteString BuiltinByteString where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: ByteString -> BuiltinByteString
toBuiltin = ByteString -> BuiltinByteString
BuiltinByteString

{- Note [noinline hack]
For some functions we have two conflicting desires:
- We want to have the unfolding available for the plugin.
- We don't want the function to *actually* get inlined before the plugin runs, since we rely
on being able to see the original function for some reason.

'INLINABLE' achieves the first, but may cause the function to be inlined too soon.

We can solve this at specific call sites by using the 'noinline' magic function from
GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if
that function is compiled later into the body of another function.

We do therefore need to handle 'noinline' in the plugin, as it itself does not have
an unfolding.

Another annoying quirk: even if you have 'noinline'd a function call, if the body is
a single variable, it will still inline! This is the case for the obvious definition
of 'stringToBuiltinString' (since the newtype constructor vanishes), so we have to add
some obfuscation to the body to prevent it inlining.
-}

-- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents
-- the unfoldings from going in. So we just stick it here. Fiddly.
instance IsString BuiltinString where
    -- Try and make sure the dictionary selector goes away, it's simpler to match on
    -- the application of 'stringToBuiltinString'
    {-# INLINE fromString #-}
    -- See Note [noinline hack]
    fromString :: String -> BuiltinString
fromString = (String -> BuiltinString) -> String -> BuiltinString
forall a. a -> a
Magic.noinline String -> BuiltinString
stringToBuiltinString

{-# INLINABLE stringToBuiltinString #-}
stringToBuiltinString :: Haskell.String -> BuiltinString
-- To explain why the obfuscatedId is here
-- See Note [noinline hack]
stringToBuiltinString :: String -> BuiltinString
stringToBuiltinString String
str = BuiltinString -> BuiltinString
forall a. a -> a
obfuscatedId (Text -> BuiltinString
BuiltinString (Text -> BuiltinString) -> Text -> BuiltinString
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
str)

{-# NOINLINE obfuscatedId #-}
obfuscatedId :: a -> a
obfuscatedId :: a -> a
obfuscatedId a
a = a
a

instance FromBuiltin BuiltinString Text where
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinString -> Text
fromBuiltin (BuiltinString Text
t) = Text
t
instance ToBuiltin Text BuiltinString where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: Text -> BuiltinString
toBuiltin = Text -> BuiltinString
BuiltinString

{- Same noinline hack as with `String` type. -}
instance IsString BuiltinByteString where
    -- Try and make sure the dictionary selector goes away, it's simpler to match on
    -- the application of 'stringToBuiltinByteString'
    {-# INLINE fromString #-}
    -- See Note [noinline hack]
    fromString :: String -> BuiltinByteString
fromString = (String -> BuiltinByteString) -> String -> BuiltinByteString
forall a. a -> a
Magic.noinline String -> BuiltinByteString
stringToBuiltinByteString

{-# INLINABLE stringToBuiltinByteString #-}
stringToBuiltinByteString :: Haskell.String -> BuiltinByteString
stringToBuiltinByteString :: String -> BuiltinByteString
stringToBuiltinByteString String
str = BuiltinString -> BuiltinByteString
encodeUtf8 (BuiltinString -> BuiltinByteString)
-> BuiltinString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ String -> BuiltinString
stringToBuiltinString String
str

{- Note [From/ToBuiltin instances for polymorphic builtin types]
For various technical reasons
(see Note [Representable built-in functions over polymorphic built-in types])
it's not always easy to provide polymorphic constructors for builtin types, but
we can usually provide destructors.

What this means in practice is that we can write a generic FromBuiltin instance
for pairs that makes use of polymorphic fst/snd builtins, but we can't write
a polymorphic ToBuiltin instance because we'd need a polymorphic version of (,).

Instead we write monomorphic instances corresponding to monomorphic constructor
builtins that we add for specific purposes.
-}

instance (FromBuiltin arep a, FromBuiltin brep b) => FromBuiltin (BuiltinPair arep brep) (a,b) where
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinPair arep brep -> (a, b)
fromBuiltin BuiltinPair arep brep
p = (arep -> a
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin (arep -> a) -> arep -> a
forall a b. (a -> b) -> a -> b
$ BuiltinPair arep brep -> arep
forall a b. BuiltinPair a b -> a
fst BuiltinPair arep brep
p, brep -> b
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin (brep -> b) -> brep -> b
forall a b. (a -> b) -> a -> b
$ BuiltinPair arep brep -> brep
forall a b. BuiltinPair a b -> b
snd BuiltinPair arep brep
p)
instance ToBuiltin (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: (BuiltinData, BuiltinData) -> BuiltinPair BuiltinData BuiltinData
toBuiltin (BuiltinData
d1, BuiltinData
d2) = BuiltinData -> BuiltinData -> BuiltinPair BuiltinData BuiltinData
mkPairData BuiltinData
d1 BuiltinData
d2

instance FromBuiltin arep a => FromBuiltin (BuiltinList arep) [a] where
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinList arep -> [a]
fromBuiltin = BuiltinList arep -> [a]
go
      where
          -- The combination of both INLINABLE and a type signature seems to stop this getting lifted to the top
          -- level, which means it gets a proper unfolding, which means that specialization can work, which can
          -- actually help quite a bit here.
          {-# INLINABLE go #-}
          go :: BuiltinList arep -> [a]
          -- Note that we are using builtin chooseList here so this is *strict* application! So we need to do
          -- the manual laziness ourselves.
          go :: BuiltinList arep -> [a]
go BuiltinList arep
l = BuiltinList arep
-> (BuiltinUnit -> [a])
-> (BuiltinUnit -> [a])
-> BuiltinUnit
-> [a]
forall a b. BuiltinList a -> b -> b -> b
chooseList BuiltinList arep
l ([a] -> BuiltinUnit -> [a]
forall a b. a -> b -> a
const []) (\BuiltinUnit
_ -> arep -> a
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin (BuiltinList arep -> arep
forall a. BuiltinList a -> a
head BuiltinList arep
l)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:BuiltinList arep -> [a]
go (BuiltinList arep -> BuiltinList arep
forall a. BuiltinList a -> BuiltinList a
tail BuiltinList arep
l)) BuiltinUnit
unitval

instance ToBuiltin [BuiltinData] (BuiltinList BuiltinData) where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: [BuiltinData] -> BuiltinList BuiltinData
toBuiltin []     = BuiltinUnit -> BuiltinList BuiltinData
mkNilData BuiltinUnit
unitval
    toBuiltin (BuiltinData
d:[BuiltinData]
ds) = BuiltinData -> BuiltinList BuiltinData -> BuiltinList BuiltinData
forall a. a -> BuiltinList a -> BuiltinList a
mkCons BuiltinData
d ([BuiltinData] -> BuiltinList BuiltinData
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin [BuiltinData]
ds)

instance ToBuiltin [(BuiltinData, BuiltinData)] (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: [(BuiltinData, BuiltinData)]
-> BuiltinList (BuiltinPair BuiltinData BuiltinData)
toBuiltin []     = BuiltinUnit -> BuiltinList (BuiltinPair BuiltinData BuiltinData)
mkNilPairData BuiltinUnit
unitval
    toBuiltin ((BuiltinData, BuiltinData)
d:[(BuiltinData, BuiltinData)]
ds) = BuiltinPair BuiltinData BuiltinData
-> BuiltinList (BuiltinPair BuiltinData BuiltinData)
-> BuiltinList (BuiltinPair BuiltinData BuiltinData)
forall a. a -> BuiltinList a -> BuiltinList a
mkCons ((BuiltinData, BuiltinData) -> BuiltinPair BuiltinData BuiltinData
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (BuiltinData, BuiltinData)
d) ([(BuiltinData, BuiltinData)]
-> BuiltinList (BuiltinPair BuiltinData BuiltinData)
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin [(BuiltinData, BuiltinData)]
ds)

instance FromBuiltin BuiltinData BuiltinData where
    {-# INLINABLE fromBuiltin #-}
    fromBuiltin :: BuiltinData -> BuiltinData
fromBuiltin = BuiltinData -> BuiltinData
forall a. a -> a
id
instance ToBuiltin BuiltinData BuiltinData where
    {-# INLINABLE toBuiltin #-}
    toBuiltin :: BuiltinData -> BuiltinData
toBuiltin = BuiltinData -> BuiltinData
forall a. a -> a
id