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

module PlutusCore.Builtin.Case where

import PlutusCore.Builtin.KnownType (HeadSpine (..))
import PlutusCore.Core.Type (Type, UniOf)
import PlutusCore.Name.Unique (TyName)

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.
  Note: you don't need to include the resulting type of the whole case matching in the
  returning list here. -}
  annotateCaseBuiltin
    :: UniOf term ~ uni
    => Type TyName uni ann
    -> [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
    -> HeadSpine Text term (Some (ValueOf uni))

-- 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 -> HeadSpine Text term (Some (ValueOf uni))
unCaserBuiltin
      :: !(forall term. UniOf term ~ uni => Some (ValueOf uni) -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
  }

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 -> HeadSpine Text term (Some (ValueOf uni)))
-> CaserBuiltin uni
forall (uni :: * -> *).
(forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni)
 -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
-> CaserBuiltin uni
CaserBuiltin Some (ValueOf uni)
-> Vector term -> HeadSpine Text term (Some (ValueOf uni))
forall term.
(UniOf term ~ uni) =>
Some (ValueOf uni)
-> Vector term -> HeadSpine Text term (Some (ValueOf uni))
forall (uni :: * -> *) term.
(CaseBuiltin uni, UniOf term ~ uni) =>
Some (ValueOf uni)
-> Vector term -> HeadSpine Text term (Some (ValueOf uni))
caseBuiltin

unavailableCaserBuiltin :: Int -> CaserBuiltin uni
unavailableCaserBuiltin :: forall (uni :: * -> *). Int -> CaserBuiltin uni
unavailableCaserBuiltin Int
ver =
  (forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni)
 -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
-> CaserBuiltin uni
forall (uni :: * -> *).
(forall term.
 (UniOf term ~ uni) =>
 Some (ValueOf uni)
 -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
-> CaserBuiltin uni
CaserBuiltin ((forall term.
  (UniOf term ~ uni) =>
  Some (ValueOf uni)
  -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
 -> CaserBuiltin uni)
-> (forall term.
    (UniOf term ~ uni) =>
    Some (ValueOf uni)
    -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
-> CaserBuiltin uni
forall a b. (a -> b) -> a -> b
$ \Some (ValueOf uni)
_ Vector term
_ ->
    Text -> HeadSpine Text term (Some (ValueOf uni))
forall err a b. err -> HeadSpine err a b
HeadError (Text -> HeadSpine Text term (Some (ValueOf uni)))
-> Text -> HeadSpine Text term (Some (ValueOf uni))
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