{-# LANGUAGE LambdaCase #-}
-- | Definition analysis for untyped Plutus Core.
-- This just adapts term-related code from PlutusCore.Analysis.Definitions;
-- we just re-use the typed machinery to do the hard work here.
module UntypedPlutusCore.Analysis.Definitions
    ( termDefs
    , runTermDefs
    ) where

import UntypedPlutusCore.Core

import PlutusCore.Analysis.Definitions (ScopeType (TermScope), UniqueInfos, addDef, addUsage)
import PlutusCore.Error (UniqueError)
import PlutusCore.Name.Unique (HasUnique, TermUnique (TermUnique), Unique (Unique))

import Control.Lens (forMOf_)
import Control.Monad.State (MonadState, execStateT)
import Control.Monad.Writer (MonadWriter, WriterT (runWriterT))

-- | Given a UPLC term, add all of its term definitions and usages, including its subterms,
-- to a global map.
termDefs
    :: (Ord ann,
        HasUnique name TermUnique,
        MonadState (UniqueInfos ann) m,
        MonadWriter [UniqueError ann] m)
    => Term name uni fun ann
    -> m ()
termDefs :: forall ann name (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique,
 MonadState (UniqueInfos ann) m, MonadWriter [UniqueError ann] m) =>
Term name uni fun ann -> m ()
termDefs Term name uni fun ann
tm = do
   Getting
  (Sequenced () m) (Term name uni fun ann) (Term name uni fun ann)
-> Term name uni fun ann -> (Term name uni fun ann -> m ()) -> m ()
forall (m :: * -> *) r s a.
Monad m =>
Getting (Sequenced r m) s a -> s -> (a -> m r) -> m ()
forMOf_ Getting
  (Sequenced () m) (Term name uni fun ann) (Term name uni fun ann)
forall name (uni :: * -> *) fun ann (f :: * -> *).
(Contravariant f, Applicative f) =>
(Term name uni fun ann -> f (Term name uni fun ann))
-> Term name uni fun ann -> f (Term name uni fun ann)
termSubtermsDeep Term name uni fun ann
tm Term name uni fun ann -> m ()
forall ann name (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique,
 MonadState (UniqueInfos ann) m, MonadWriter [UniqueError ann] m) =>
Term name uni fun ann -> m ()
handleTerm

handleTerm :: (Ord ann,
        HasUnique name TermUnique,
        MonadState (UniqueInfos ann) m,
        MonadWriter [UniqueError ann] m)
    => Term name uni fun ann
    -> m ()
handleTerm :: forall ann name (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique,
 MonadState (UniqueInfos ann) m, MonadWriter [UniqueError ann] m) =>
Term name uni fun ann -> m ()
handleTerm = \case
    Var ann
ann name
n      ->
        name -> ann -> ScopeType -> m ()
forall ann n unique (m :: * -> *).
(Ord ann, HasUnique n unique, MonadState (UniqueInfos ann) m,
 MonadWriter [UniqueError ann] m) =>
n -> ann -> ScopeType -> m ()
addUsage name
n ann
ann ScopeType
TermScope
    LamAbs ann
ann name
n Term name uni fun ann
_ ->
        name -> ann -> ScopeType -> m ()
forall ann n unique (m :: * -> *).
(Ord ann, HasUnique n unique, MonadState (UniqueInfos ann) m,
 MonadWriter [UniqueError ann] m) =>
n -> ann -> ScopeType -> m ()
addDef name
n ann
ann ScopeType
TermScope
    Term name uni fun ann
_               -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runTermDefs
    :: (Ord ann,
        HasUnique name TermUnique,
        Monad m)
    => Term name uni fun ann
    -> m (UniqueInfos ann, [UniqueError ann])
runTermDefs :: forall ann name (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique, Monad m) =>
Term name uni fun ann -> m (UniqueInfos ann, [UniqueError ann])
runTermDefs = WriterT [UniqueError ann] m (UniqueInfos ann)
-> m (UniqueInfos ann, [UniqueError ann])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [UniqueError ann] m (UniqueInfos ann)
 -> m (UniqueInfos ann, [UniqueError ann]))
-> (Term name uni fun ann
    -> WriterT [UniqueError ann] m (UniqueInfos ann))
-> Term name uni fun ann
-> m (UniqueInfos ann, [UniqueError ann])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (UniqueInfos ann) (WriterT [UniqueError ann] m) ()
 -> UniqueInfos ann
 -> WriterT [UniqueError ann] m (UniqueInfos ann))
-> UniqueInfos ann
-> StateT (UniqueInfos ann) (WriterT [UniqueError ann] m) ()
-> WriterT [UniqueError ann] m (UniqueInfos ann)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (UniqueInfos ann) (WriterT [UniqueError ann] m) ()
-> UniqueInfos ann -> WriterT [UniqueError ann] m (UniqueInfos ann)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT UniqueInfos ann
forall a. Monoid a => a
mempty (StateT (UniqueInfos ann) (WriterT [UniqueError ann] m) ()
 -> WriterT [UniqueError ann] m (UniqueInfos ann))
-> (Term name uni fun ann
    -> StateT (UniqueInfos ann) (WriterT [UniqueError ann] m) ())
-> Term name uni fun ann
-> WriterT [UniqueError ann] m (UniqueInfos ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term name uni fun ann
-> StateT (UniqueInfos ann) (WriterT [UniqueError ann] m) ()
forall ann name (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique,
 MonadState (UniqueInfos ann) m, MonadWriter [UniqueError ann] m) =>
Term name uni fun ann -> m ()
termDefs