{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
-- | Module handling provenances of terms.
module PlutusIR.Compiler.Provenance where

import PlutusIR

import PlutusCore.Pretty qualified as PLC

import Data.Set qualified as S
import Prettyprinter ((<+>))
import Prettyprinter qualified as PP

-- | Indicates where a value comes from.
--
-- This is either an original annotation or a pieces of context explaining how the term
-- relates to a previous 'Provenance'. We also provide 'NoProvenance' for convenience.
--
-- The provenance should always be just the original annotation, if we have one. It should only be another
-- kind of provenance if we're in the process of generating some term that doesn't correspond directly to a term in
-- the original AST.
data Provenance a = Original a
                  | LetBinding Recursivity (Provenance a)
                  | TermBinding String (Provenance a)
                  | TypeBinding String (Provenance a)
                  | DatatypeComponent DatatypeComponent (Provenance a)
                  -- | Added for accumulating difference provenances when floating lets
                  | MultipleSources (S.Set (Provenance a))
                  deriving stock (Int -> Provenance a -> ShowS
[Provenance a] -> ShowS
Provenance a -> String
(Int -> Provenance a -> ShowS)
-> (Provenance a -> String)
-> ([Provenance a] -> ShowS)
-> Show (Provenance a)
forall a. Show a => Int -> Provenance a -> ShowS
forall a. Show a => [Provenance a] -> ShowS
forall a. Show a => Provenance a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Provenance a] -> ShowS
$cshowList :: forall a. Show a => [Provenance a] -> ShowS
show :: Provenance a -> String
$cshow :: forall a. Show a => Provenance a -> String
showsPrec :: Int -> Provenance a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Provenance a -> ShowS
Show, Provenance a -> Provenance a -> Bool
(Provenance a -> Provenance a -> Bool)
-> (Provenance a -> Provenance a -> Bool) -> Eq (Provenance a)
forall a. Eq a => Provenance a -> Provenance a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Provenance a -> Provenance a -> Bool
$c/= :: forall a. Eq a => Provenance a -> Provenance a -> Bool
== :: Provenance a -> Provenance a -> Bool
$c== :: forall a. Eq a => Provenance a -> Provenance a -> Bool
Eq, Eq (Provenance a)
Eq (Provenance a)
-> (Provenance a -> Provenance a -> Ordering)
-> (Provenance a -> Provenance a -> Bool)
-> (Provenance a -> Provenance a -> Bool)
-> (Provenance a -> Provenance a -> Bool)
-> (Provenance a -> Provenance a -> Bool)
-> (Provenance a -> Provenance a -> Provenance a)
-> (Provenance a -> Provenance a -> Provenance a)
-> Ord (Provenance a)
Provenance a -> Provenance a -> Bool
Provenance a -> Provenance a -> Ordering
Provenance a -> Provenance a -> Provenance a
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
forall a. Ord a => Eq (Provenance a)
forall a. Ord a => Provenance a -> Provenance a -> Bool
forall a. Ord a => Provenance a -> Provenance a -> Ordering
forall a. Ord a => Provenance a -> Provenance a -> Provenance a
min :: Provenance a -> Provenance a -> Provenance a
$cmin :: forall a. Ord a => Provenance a -> Provenance a -> Provenance a
max :: Provenance a -> Provenance a -> Provenance a
$cmax :: forall a. Ord a => Provenance a -> Provenance a -> Provenance a
>= :: Provenance a -> Provenance a -> Bool
$c>= :: forall a. Ord a => Provenance a -> Provenance a -> Bool
> :: Provenance a -> Provenance a -> Bool
$c> :: forall a. Ord a => Provenance a -> Provenance a -> Bool
<= :: Provenance a -> Provenance a -> Bool
$c<= :: forall a. Ord a => Provenance a -> Provenance a -> Bool
< :: Provenance a -> Provenance a -> Bool
$c< :: forall a. Ord a => Provenance a -> Provenance a -> Bool
compare :: Provenance a -> Provenance a -> Ordering
$ccompare :: forall a. Ord a => Provenance a -> Provenance a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Provenance a)
Ord)

instance Ord a => Semigroup (Provenance a) where
  MultipleSources Set (Provenance a)
ps1 <> :: Provenance a -> Provenance a -> Provenance a
<> MultipleSources Set (Provenance a)
ps2 = Set (Provenance a) -> Provenance a
forall a. Set (Provenance a) -> Provenance a
MultipleSources (Set (Provenance a)
ps1Set (Provenance a) -> Set (Provenance a) -> Set (Provenance a)
forall a. Semigroup a => a -> a -> a
<>Set (Provenance a)
ps2)
  Provenance a
x <> MultipleSources Set (Provenance a)
ps2                   = Set (Provenance a) -> Provenance a
forall a. Set (Provenance a) -> Provenance a
MultipleSources (Provenance a -> Set (Provenance a) -> Set (Provenance a)
forall a. Ord a => a -> Set a -> Set a
S.insert Provenance a
x Set (Provenance a)
ps2)
  MultipleSources Set (Provenance a)
ps1 <> Provenance a
x                   = Set (Provenance a) -> Provenance a
forall a. Set (Provenance a) -> Provenance a
MultipleSources (Provenance a -> Set (Provenance a) -> Set (Provenance a)
forall a. Ord a => a -> Set a -> Set a
S.insert Provenance a
x Set (Provenance a)
ps1)
  Provenance a
x <> Provenance a
y                                     = Set (Provenance a) -> Provenance a
forall a. Set (Provenance a) -> Provenance a
MultipleSources ([Provenance a] -> Set (Provenance a)
forall a. Ord a => [a] -> Set a
S.fromList [Provenance a
x,Provenance a
y])

-- workaround, use a smart constructor to replace the older NoProvenance data constructor
noProvenance :: Provenance a
noProvenance :: Provenance a
noProvenance = Set (Provenance a) -> Provenance a
forall a. Set (Provenance a) -> Provenance a
MultipleSources Set (Provenance a)
forall a. Set a
S.empty

data DatatypeComponent = Constructor
                       | ConstructorType
                       | Destructor
                       | DestructorType
                       | DatatypeType
                       | PatternFunctor
                       deriving stock (Int -> DatatypeComponent -> ShowS
[DatatypeComponent] -> ShowS
DatatypeComponent -> String
(Int -> DatatypeComponent -> ShowS)
-> (DatatypeComponent -> String)
-> ([DatatypeComponent] -> ShowS)
-> Show DatatypeComponent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DatatypeComponent] -> ShowS
$cshowList :: [DatatypeComponent] -> ShowS
show :: DatatypeComponent -> String
$cshow :: DatatypeComponent -> String
showsPrec :: Int -> DatatypeComponent -> ShowS
$cshowsPrec :: Int -> DatatypeComponent -> ShowS
Show, DatatypeComponent -> DatatypeComponent -> Bool
(DatatypeComponent -> DatatypeComponent -> Bool)
-> (DatatypeComponent -> DatatypeComponent -> Bool)
-> Eq DatatypeComponent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DatatypeComponent -> DatatypeComponent -> Bool
$c/= :: DatatypeComponent -> DatatypeComponent -> Bool
== :: DatatypeComponent -> DatatypeComponent -> Bool
$c== :: DatatypeComponent -> DatatypeComponent -> Bool
Eq, Eq DatatypeComponent
Eq DatatypeComponent
-> (DatatypeComponent -> DatatypeComponent -> Ordering)
-> (DatatypeComponent -> DatatypeComponent -> Bool)
-> (DatatypeComponent -> DatatypeComponent -> Bool)
-> (DatatypeComponent -> DatatypeComponent -> Bool)
-> (DatatypeComponent -> DatatypeComponent -> Bool)
-> (DatatypeComponent -> DatatypeComponent -> DatatypeComponent)
-> (DatatypeComponent -> DatatypeComponent -> DatatypeComponent)
-> Ord DatatypeComponent
DatatypeComponent -> DatatypeComponent -> Bool
DatatypeComponent -> DatatypeComponent -> Ordering
DatatypeComponent -> DatatypeComponent -> DatatypeComponent
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 :: DatatypeComponent -> DatatypeComponent -> DatatypeComponent
$cmin :: DatatypeComponent -> DatatypeComponent -> DatatypeComponent
max :: DatatypeComponent -> DatatypeComponent -> DatatypeComponent
$cmax :: DatatypeComponent -> DatatypeComponent -> DatatypeComponent
>= :: DatatypeComponent -> DatatypeComponent -> Bool
$c>= :: DatatypeComponent -> DatatypeComponent -> Bool
> :: DatatypeComponent -> DatatypeComponent -> Bool
$c> :: DatatypeComponent -> DatatypeComponent -> Bool
<= :: DatatypeComponent -> DatatypeComponent -> Bool
$c<= :: DatatypeComponent -> DatatypeComponent -> Bool
< :: DatatypeComponent -> DatatypeComponent -> Bool
$c< :: DatatypeComponent -> DatatypeComponent -> Bool
compare :: DatatypeComponent -> DatatypeComponent -> Ordering
$ccompare :: DatatypeComponent -> DatatypeComponent -> Ordering
$cp1Ord :: Eq DatatypeComponent
Ord)

instance PP.Pretty DatatypeComponent where
    pretty :: DatatypeComponent -> Doc ann
pretty = \case
        DatatypeComponent
Constructor     -> Doc ann
"constructor"
        DatatypeComponent
ConstructorType -> Doc ann
"constructor type"
        DatatypeComponent
Destructor      -> Doc ann
"destructor"
        DatatypeComponent
DestructorType  -> Doc ann
"destructor type"
        DatatypeComponent
DatatypeType    -> Doc ann
"datatype type"
        DatatypeComponent
PatternFunctor  -> Doc ann
"pattern functor"

data GeneratedKind = RecursiveLet
    deriving stock (Int -> GeneratedKind -> ShowS
[GeneratedKind] -> ShowS
GeneratedKind -> String
(Int -> GeneratedKind -> ShowS)
-> (GeneratedKind -> String)
-> ([GeneratedKind] -> ShowS)
-> Show GeneratedKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GeneratedKind] -> ShowS
$cshowList :: [GeneratedKind] -> ShowS
show :: GeneratedKind -> String
$cshow :: GeneratedKind -> String
showsPrec :: Int -> GeneratedKind -> ShowS
$cshowsPrec :: Int -> GeneratedKind -> ShowS
Show, GeneratedKind -> GeneratedKind -> Bool
(GeneratedKind -> GeneratedKind -> Bool)
-> (GeneratedKind -> GeneratedKind -> Bool) -> Eq GeneratedKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GeneratedKind -> GeneratedKind -> Bool
$c/= :: GeneratedKind -> GeneratedKind -> Bool
== :: GeneratedKind -> GeneratedKind -> Bool
$c== :: GeneratedKind -> GeneratedKind -> Bool
Eq)

instance PP.Pretty GeneratedKind where
    pretty :: GeneratedKind -> Doc ann
pretty = \case
        GeneratedKind
RecursiveLet -> Doc ann
"recursive let"

-- | Set the provenance on a term to the given value.
setProvenance :: Functor f => Provenance b -> f a -> f (Provenance b)
setProvenance :: Provenance b -> f a -> f (Provenance b)
setProvenance = Provenance b -> f a -> f (Provenance b)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$)

-- | Mark all the annotations on a term as original. Useful for preparing terms for the PIR compiler.
original :: Functor f => f a -> f (Provenance a)
original :: f a -> f (Provenance a)
original = (a -> Provenance a) -> f a -> f (Provenance a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Provenance a
forall a. a -> Provenance a
Original

instance PP.Pretty a => PP.Pretty (Provenance a) where
    pretty :: Provenance a -> Doc ann
pretty = \case
        DatatypeComponent DatatypeComponent
c Provenance a
p -> DatatypeComponent -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty DatatypeComponent
c Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"from" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Provenance a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PLC.pretty Provenance a
p
        Original a
p -> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PLC.pretty a
p
        LetBinding Recursivity
r Provenance a
p ->
            let
                rstr :: Doc ann
rstr = case Recursivity
r of
                    Recursivity
NonRec -> Doc ann
"non-recursive"
                    Recursivity
Rec    -> Doc ann
"recursive"
            in Doc ann
"(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
rstr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"let binding" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"from" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Provenance a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PLC.pretty Provenance a
p
        TermBinding String
n Provenance a
p -> Doc ann
"term binding" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"of" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PLC.pretty String
n Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"from" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Provenance a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PLC.pretty Provenance a
p
        TypeBinding String
n Provenance a
p -> Doc ann
"type binding" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"of" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PLC.pretty String
n Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"from" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Provenance a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PLC.pretty Provenance a
p
        MultipleSources Set (Provenance a)
p1 -> case Set (Provenance a) -> [Provenance a]
forall a. Set a -> [a]
S.toList Set (Provenance a)
p1 of
                                [] -> Doc ann
"<unknown>"
                                [Provenance a]
l  -> [Provenance a] -> Doc ann
forall a ann. Pretty a => [a] -> Doc ann
PLC.prettyList [Provenance a]
l