{-# 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 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

{-# 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 :->