{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE ImportQualifiedPost   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Plutus.Contract.Test.Coverage.Analysis.Common where
import Control.DeepSeq
import Data.Text qualified as Text
import Debug.Trace
import GHC.Stack
import PlutusCore.DeBruijn hiding (DeBruijn)
import PlutusCore.Default
import PlutusCore.Name
import PlutusIR
import PlutusIR.Compiler
import PlutusTx.Coverage
import Text.PrettyPrint hiding (integer, (<>))
import Text.Read (readMaybe)

type Trm = Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ()
type Typ = Type NamedTyDeBruijn DefaultUni ()
type Kin = Kind ()
type Dat = Datatype NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ()
type Bind = Binding NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ()

type Trm'  = Term TyName Name DefaultUni DefaultFun ()
type Typ'  = Type TyName DefaultUni ()
type Dat'  = Datatype TyName Name DefaultUni DefaultFun ()
type Bind' = Binding TyName Name DefaultUni DefaultFun ()
type Err'  = Error DefaultUni DefaultFun ()

pattern BIF_Trace :: Term tyname name uni DefaultFun ()
pattern $bBIF_Trace :: Term tyname name uni DefaultFun ()
$mBIF_Trace :: forall r tyname name (uni :: * -> *).
Term tyname name uni DefaultFun ()
-> (Void# -> r) -> (Void# -> r) -> r
BIF_Trace = Builtin () Trace

pattern BIF_If :: Term tyname name uni DefaultFun ()
pattern $bBIF_If :: Term tyname name uni DefaultFun ()
$mBIF_If :: forall r tyname name (uni :: * -> *).
Term tyname name uni DefaultFun ()
-> (Void# -> r) -> (Void# -> r) -> r
BIF_If = Builtin () IfThenElse

pattern LIT_Loc :: CoverageAnnotation -> Term tyname name DefaultUni fun ()
pattern $bLIT_Loc :: CoverageAnnotation -> Term tyname name DefaultUni fun ()
$mLIT_Loc :: forall r tyname name fun.
Term tyname name DefaultUni fun ()
-> (CoverageAnnotation -> r) -> (Void# -> r) -> r
LIT_Loc l <- Constant _ (Some (ValueOf DefaultUniString (readMaybe . Text.unpack -> Just l)))
  where LIT_Loc CoverageAnnotation
l = ()
-> Some (ValueOf DefaultUni) -> Term tyname name DefaultUni fun ()
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
Constant () (ValueOf DefaultUni Text -> Some (ValueOf DefaultUni)
forall k (tag :: k -> *) (a :: k). tag a -> Some tag
Some (DefaultUni (Esc Text) -> Text -> ValueOf DefaultUni Text
forall (uni :: * -> *) a. uni (Esc a) -> a -> ValueOf uni a
ValueOf DefaultUni (Esc Text)
DefaultUniString (String -> Text
Text.pack (CoverageAnnotation -> String
forall a. Show a => a -> String
show CoverageAnnotation
l))))

pattern Const :: DefaultUni (Esc a) -> a -> Term tyname name DefaultUni fun ()
pattern $bConst :: DefaultUni (Esc a) -> a -> Term tyname name DefaultUni fun ()
$mConst :: forall r tyname name fun.
Term tyname name DefaultUni fun ()
-> (forall a. DefaultUni (Esc a) -> a -> r) -> (Void# -> r) -> r
Const b a = Constant () (Some (ValueOf b a))

builtinKind :: SomeTypeIn DefaultUni -> Kin
builtinKind :: SomeTypeIn DefaultUni -> Kin
builtinKind (SomeTypeIn DefaultUni (Esc a)
t) = case DefaultUni (Esc a)
t of
  DefaultUni (Esc a)
DefaultUniProtoList -> Kin
Star Kin -> Kin -> Kin
:-> Kin
Star
  DefaultUni (Esc a)
DefaultUniProtoPair -> Kin
Star Kin -> Kin -> Kin
:-> Kin
Star Kin -> Kin -> Kin
:-> Kin
Star
  DefaultUniApply DefaultUni (Esc f)
f DefaultUni (Esc a1)
_ -> let Kin
_ :-> Kin
k = SomeTypeIn DefaultUni -> Kin
builtinKind (DefaultUni (Esc f) -> SomeTypeIn DefaultUni
forall (uni :: * -> *) k (a :: k). uni (Esc a) -> SomeTypeIn uni
SomeTypeIn DefaultUni (Esc f)
f) in Kin
k
  DefaultUni (Esc a)
_                   -> Kin
Star

-- *** Debug helpers
data Verbosity = Low
               | Med
               | High
               | Unions
               deriving (Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord, Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)

debug :: Bool
debug :: Bool
debug = Bool
False

verbosity :: [Verbosity]
verbosity :: [Verbosity]
verbosity = []

traceDoc :: Verbosity -> Doc -> a -> a
traceDoc :: Verbosity -> Doc -> a -> a
traceDoc Verbosity
v Doc
d a
a | Bool
debug Bool -> Bool -> Bool
&& Verbosity
v Verbosity -> [Verbosity] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Verbosity]
verbosity = String -> a -> a
forall a. String -> a -> a
trace (Doc -> String
forall a. Show a => a -> String
show Doc
d) a
a
               | Bool
otherwise = a
a

traceDocIf :: Bool -> Verbosity -> Doc -> a -> a
traceDocIf :: Bool -> Verbosity -> Doc -> a -> a
traceDocIf Bool
True = Verbosity -> Doc -> a -> a
forall a. Verbosity -> Doc -> a -> a
traceDoc
traceDocIf Bool
_    = \ Verbosity
_ Doc
_ a
a -> a
a

errorDoc :: HasCallStack => Doc -> a
errorDoc :: Doc -> a
errorDoc = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (Doc -> String) -> Doc -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Doc -> String) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
forall a. Show a => a -> String
show

deriving instance NFData Trm'
deriving instance NFData Bind'
deriving instance NFData (VarDecl TyName Name DefaultUni DefaultFun ())
deriving instance NFData (TyVarDecl TyName ())
deriving instance NFData Dat'
deriving instance NFData Strictness
deriving instance NFData Recursivity

deriving instance NFData (TyVarDecl NamedTyDeBruijn ())
deriving instance NFData Dat
deriving instance NFData (VarDecl NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
deriving instance NFData Bind
deriving instance NFData Trm

{-# COMPLETE Star, (:->) #-}
pattern Star :: Kin
pattern $bStar :: Kin
$mStar :: forall r. Kin -> (Void# -> r) -> (Void# -> r) -> r
Star  = Type ()

pattern (:->) :: Kin -> Kin -> Kin
pattern $b:-> :: Kin -> Kin -> Kin
$m:-> :: forall r. Kin -> (Kin -> Kin -> r) -> (Void# -> r) -> r
(:->) a b = KindArrow () a b
infixr 3 :->