{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TypeOperators     #-}

module PlutusCore.Builtin.Case where

import PlutusCore.Core.Type (Type, UniOf)
import PlutusCore.Name.Unique

import Control.DeepSeq (NFData (..), rwhnf)
import Data.Default.Class (Default (..))
import Data.Text (Text)
import Data.Vector (Vector)
import NoThunks.Class
import Text.PrettyBy (display)
import Universe

class AnnotateCaseBuiltin uni where
    -- | Given a tag for a built-in type and a list of branches, annotate each of the branches with
    -- its expected argument types or fail if casing on values of the built-in type isn't supported.
    annotateCaseBuiltin
        :: UniOf term ~ uni
        => SomeTypeIn uni
        -> [term]
        -> Either Text [(term, [Type TyName uni ann])]

class CaseBuiltin uni where
    -- | Given a constant with its type tag and a vector of branches, choose the appropriate branch
    -- or fail if the constant doesn't correspond to any of the branches (or casing on constants of
    -- this type isn't supported at all).
    caseBuiltin :: UniOf term ~ uni => Some (ValueOf uni) -> Vector term -> Either Text term

-- See Note [DO NOT newtype-wrap functions].
-- | A @data@ version of 'CaseBuiltin'. we parameterize the evaluator by a 'CaserBuiltin' so that
-- the caller can choose whether to use the 'caseBuiltin' method or the always failing caser (the
-- latter is required for earlier protocol versions when we didn't support casing on builtins).
data CaserBuiltin uni = CaserBuiltin
    { forall (uni :: * -> *).
CaserBuiltin uni
-> forall term.
   (UniOf term ~ uni) =>
   Some (ValueOf uni) -> Vector term -> Either Text term
unCaserBuiltin
        :: !(forall term. UniOf term ~ uni => Some (ValueOf uni) -> Vector term -> Either Text term)
    }

instance NFData (CaserBuiltin uni) where
    rnf :: CaserBuiltin uni -> ()
rnf = CaserBuiltin uni -> ()
forall a. a -> ()
rwhnf

deriving via OnlyCheckWhnfNamed "PlutusCore.Builtin.Case.CaserBuiltin" (CaserBuiltin uni)
    instance NoThunks (CaserBuiltin uni)

instance CaseBuiltin uni => Default (CaserBuiltin uni) where
    def :: CaserBuiltin uni
def = (forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni) -> Vector term -> Either Text term)
-> CaserBuiltin uni
forall (uni :: * -> *).
(forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni) -> Vector term -> Either Text term)
-> CaserBuiltin uni
CaserBuiltin Some (ValueOf uni) -> Vector term -> Either Text term
forall term.
(UniOf term ~ uni) =>
Some (ValueOf uni) -> Vector term -> Either Text term
forall (uni :: * -> *) term.
(CaseBuiltin uni, UniOf term ~ uni) =>
Some (ValueOf uni) -> Vector term -> Either Text term
caseBuiltin

unavailableCaserBuiltin :: Int -> CaserBuiltin uni
unavailableCaserBuiltin :: forall (uni :: * -> *). Int -> CaserBuiltin uni
unavailableCaserBuiltin Int
ver =
    (forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni) -> Vector term -> Either Text term)
-> CaserBuiltin uni
forall (uni :: * -> *).
(forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni) -> Vector term -> Either Text term)
-> CaserBuiltin uni
CaserBuiltin ((forall term.
  (UniOf term ~ uni) =>
  Some (ValueOf uni) -> Vector term -> Either Text term)
 -> CaserBuiltin uni)
-> (forall term.
    (UniOf term ~ uni) =>
    Some (ValueOf uni) -> Vector term -> Either Text term)
-> CaserBuiltin uni
forall a b. (a -> b) -> a -> b
$ \Some (ValueOf uni)
_ Vector term
_ -> Text -> Either Text term
forall a b. a -> Either a b
Left (Text -> Either Text term) -> Text -> Either Text term
forall a b. (a -> b) -> a -> b
$
        Text
"'case' on values of built-in types is not supported in protocol version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall str a. (Pretty a, Render str) => a -> str
display Int
ver