{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module PlutusIR.Analysis.RetainedSize
( RetainedSize (..)
, Size (..)
, termRetentionMap
, annotateWithRetainedSize
) where
import PlutusPrelude
import PlutusIR.Analysis.Dependencies
import PlutusIR.Analysis.Size
import PlutusIR.Core
import PlutusCore qualified as PLC
import PlutusCore.Builtin as PLC
import PlutusCore.Name.Unique
import Algebra.Graph qualified as C
import Algebra.Graph.ToGraph
import Control.Lens
import Data.Graph.Dom (domTree)
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.Tree
import PlutusCore.Name.UniqueMap qualified as UMap
import PlutusIR.Analysis.Builtins
import PlutusIR.Analysis.VarInfo
data RetainedSize
= Retains Size
| NotARetainer
deriving stock (Int -> RetainedSize -> ShowS
[RetainedSize] -> ShowS
RetainedSize -> String
(Int -> RetainedSize -> ShowS)
-> (RetainedSize -> String)
-> ([RetainedSize] -> ShowS)
-> Show RetainedSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetainedSize -> ShowS
showsPrec :: Int -> RetainedSize -> ShowS
$cshow :: RetainedSize -> String
show :: RetainedSize -> String
$cshowList :: [RetainedSize] -> ShowS
showList :: [RetainedSize] -> ShowS
Show)
instance Pretty RetainedSize where
pretty :: forall ann. RetainedSize -> Doc ann
pretty (Retains Size
size) = Doc ann
"$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Size -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Size -> Doc ann
pretty Size
size Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"$"
pretty RetainedSize
NotARetainer = Doc ann
forall a. Monoid a => a
mempty
rootInt :: Int
rootInt :: Int
rootInt = -Int
1
nodeToInt :: Node -> Int
nodeToInt :: Node -> Int
nodeToInt (Variable (PLC.Unique Int
i)) = Int
i
nodeToInt Node
Root = Int
rootInt
newtype DirectionRetentionMap = DirectionRetentionMap (IntMap Size)
lookupSize :: Int -> DirectionRetentionMap -> Size
lookupSize :: Int -> DirectionRetentionMap -> Size
lookupSize Int
i (DirectionRetentionMap IntMap Size
ss) = IntMap Size
ss IntMap Size -> Int -> Size
forall a. IntMap a -> Int -> a
IntMap.! Int
i
annotateWithSizes :: DirectionRetentionMap -> Tree Int -> Tree (Int, Size)
annotateWithSizes :: DirectionRetentionMap -> Tree Int -> Tree (Int, Size)
annotateWithSizes DirectionRetentionMap
sizeInfo = Tree Int -> Tree (Int, Size)
go where
go :: Tree Int -> Tree (Int, Size)
go (Node Int
i [Tree Int]
ts) = (Int, Size) -> [Tree (Int, Size)] -> Tree (Int, Size)
forall a. a -> [Tree a] -> Tree a
Node (Int
i, Size
sizeI) [Tree (Int, Size)]
rs where
rs :: [Tree (Int, Size)]
rs = (Tree Int -> Tree (Int, Size)) -> [Tree Int] -> [Tree (Int, Size)]
forall a b. (a -> b) -> [a] -> [b]
map Tree Int -> Tree (Int, Size)
go [Tree Int]
ts
sizeI :: Size
sizeI = Int -> DirectionRetentionMap -> Size
lookupSize Int
i DirectionRetentionMap
sizeInfo Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> (Tree (Int, Size) -> Size) -> [Tree (Int, Size)] -> Size
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Int, Size) -> Size
forall a b. (a, b) -> b
snd ((Int, Size) -> Size)
-> (Tree (Int, Size) -> (Int, Size)) -> Tree (Int, Size) -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (Int, Size) -> (Int, Size)
forall a. Tree a -> a
rootLabel) [Tree (Int, Size)]
rs
toDomTree :: C.Graph Node -> Tree Int
toDomTree :: Graph Node -> Tree Int
toDomTree = Rooted -> Tree Int
domTree (Rooted -> Tree Int)
-> (Graph Node -> Rooted) -> Graph Node -> Tree Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Int
rootInt (Graph -> Rooted) -> (Graph Node -> Graph) -> Graph Node -> Rooted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph Int -> Graph
forall t. (ToGraph t, ToVertex t ~ Int) => t -> Graph
adjacencyIntMap (Graph Int -> Graph)
-> (Graph Node -> Graph Int) -> Graph Node -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Int) -> Graph Node -> Graph Int
forall a b. (a -> b) -> Graph a -> Graph b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Int
nodeToInt
depsRetentionMap :: DirectionRetentionMap -> C.Graph Node -> IntMap Size
depsRetentionMap :: DirectionRetentionMap -> Graph Node -> IntMap Size
depsRetentionMap DirectionRetentionMap
sizeInfo = [(Int, Size)] -> IntMap Size
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, Size)] -> IntMap Size)
-> (Graph Node -> [(Int, Size)]) -> Graph Node -> IntMap Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (Int, Size) -> [(Int, Size)]
forall a. Tree a -> [a]
flatten (Tree (Int, Size) -> [(Int, Size)])
-> (Graph Node -> Tree (Int, Size)) -> Graph Node -> [(Int, Size)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirectionRetentionMap -> Tree Int -> Tree (Int, Size)
annotateWithSizes DirectionRetentionMap
sizeInfo (Tree Int -> Tree (Int, Size))
-> (Graph Node -> Tree Int) -> Graph Node -> Tree (Int, Size)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph Node -> Tree Int
toDomTree
bindingSize
:: (HasUnique tyname TypeUnique, HasUnique name TermUnique)
=> Binding tyname name uni fun ann -> PLC.UniqueMap Unique Size
bindingSize :: forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Binding tyname name uni fun ann -> UniqueMap Unique Size
bindingSize (TermBind ann
_ Strictness
_ VarDecl tyname name uni ann
var Term tyname name uni fun ann
term) =
VarDecl tyname name uni ann
-> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall name unique1 unique2 a.
(HasUnique name unique1, Coercible unique2 Unique) =>
name -> a -> UniqueMap unique2 a -> UniqueMap unique2 a
UMap.insertByNameIndex VarDecl tyname name uni ann
var (VarDecl tyname name uni ann -> Size
forall tyname name (uni :: * -> *) ann.
VarDecl tyname name uni ann -> Size
varDeclSize VarDecl tyname name uni ann
var Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Term tyname name uni fun ann -> Size
forall tyname name (uni :: * -> *) fun ann.
Term tyname name uni fun ann -> Size
termSize Term tyname name uni fun ann
term) UniqueMap Unique Size
forall a. Monoid a => a
mempty
bindingSize (TypeBind ann
_ TyVarDecl tyname ann
tyVar Type tyname uni ann
ty) =
TyVarDecl tyname ann
-> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall name unique1 unique2 a.
(HasUnique name unique1, Coercible unique2 Unique) =>
name -> a -> UniqueMap unique2 a -> UniqueMap unique2 a
UMap.insertByNameIndex TyVarDecl tyname ann
tyVar (TyVarDecl tyname ann -> Size
forall tyname ann. TyVarDecl tyname ann -> Size
tyVarDeclSize TyVarDecl tyname ann
tyVar Size -> Size -> Size
forall a. Semigroup a => a -> a -> a
<> Type tyname uni ann -> Size
forall tyname (uni :: * -> *) ann. Type tyname uni ann -> Size
typeSize Type tyname uni ann
ty) UniqueMap Unique Size
forall a. Monoid a => a
mempty
bindingSize (DatatypeBind ann
_ (Datatype ann
_ TyVarDecl tyname ann
dataDecl [TyVarDecl tyname ann]
params name
matchName [VarDecl tyname name uni ann]
constrs))
= TyVarDecl tyname ann
-> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall name unique1 unique2 a.
(HasUnique name unique1, Coercible unique2 Unique) =>
name -> a -> UniqueMap unique2 a -> UniqueMap unique2 a
UMap.insertByNameIndex TyVarDecl tyname ann
dataDecl (TyVarDecl tyname ann -> Size
forall tyname ann. TyVarDecl tyname ann -> Size
tyVarDeclSize TyVarDecl tyname ann
dataDecl)
(UniqueMap Unique Size -> UniqueMap Unique Size)
-> (UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> UniqueMap Unique Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniqueMap Unique Size
-> [TyVarDecl tyname ann] -> UniqueMap Unique Size)
-> [TyVarDecl tyname ann]
-> UniqueMap Unique Size
-> UniqueMap Unique Size
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((TyVarDecl tyname ann
-> UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> [TyVarDecl tyname ann]
-> UniqueMap Unique Size
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((TyVarDecl tyname ann
-> UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> [TyVarDecl tyname ann]
-> UniqueMap Unique Size)
-> (TyVarDecl tyname ann
-> UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> [TyVarDecl tyname ann]
-> UniqueMap Unique Size
forall a b. (a -> b) -> a -> b
$ \TyVarDecl tyname ann
param -> TyVarDecl tyname ann
-> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall name unique1 unique2 a.
(HasUnique name unique1, Coercible unique2 Unique) =>
name -> a -> UniqueMap unique2 a -> UniqueMap unique2 a
UMap.insertByNameIndex TyVarDecl tyname ann
param (Size -> UniqueMap Unique Size -> UniqueMap Unique Size)
-> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall a b. (a -> b) -> a -> b
$ TyVarDecl tyname ann -> Size
forall tyname ann. TyVarDecl tyname ann -> Size
tyVarDeclSize TyVarDecl tyname ann
param) [TyVarDecl tyname ann]
params
(UniqueMap Unique Size -> UniqueMap Unique Size)
-> (UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> UniqueMap Unique Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall name unique1 unique2 a.
(HasUnique name unique1, Coercible unique2 Unique) =>
name -> a -> UniqueMap unique2 a -> UniqueMap unique2 a
UMap.insertByNameIndex name
matchName (Integer -> Size
Size Integer
1)
(UniqueMap Unique Size -> UniqueMap Unique Size)
-> (UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> UniqueMap Unique Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniqueMap Unique Size
-> [VarDecl tyname name uni ann] -> UniqueMap Unique Size)
-> [VarDecl tyname name uni ann]
-> UniqueMap Unique Size
-> UniqueMap Unique Size
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((VarDecl tyname name uni ann
-> UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> [VarDecl tyname name uni ann]
-> UniqueMap Unique Size
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((VarDecl tyname name uni ann
-> UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> [VarDecl tyname name uni ann]
-> UniqueMap Unique Size)
-> (VarDecl tyname name uni ann
-> UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size
-> [VarDecl tyname name uni ann]
-> UniqueMap Unique Size
forall a b. (a -> b) -> a -> b
$ \VarDecl tyname name uni ann
constr -> VarDecl tyname name uni ann
-> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall name unique1 unique2 a.
(HasUnique name unique1, Coercible unique2 Unique) =>
name -> a -> UniqueMap unique2 a -> UniqueMap unique2 a
UMap.insertByNameIndex VarDecl tyname name uni ann
constr (Size -> UniqueMap Unique Size -> UniqueMap Unique Size)
-> Size -> UniqueMap Unique Size -> UniqueMap Unique Size
forall a b. (a -> b) -> a -> b
$ VarDecl tyname name uni ann -> Size
forall tyname name (uni :: * -> *) ann.
VarDecl tyname name uni ann -> Size
varDeclSize VarDecl tyname name uni ann
constr) [VarDecl tyname name uni ann]
constrs
(UniqueMap Unique Size -> UniqueMap Unique Size)
-> UniqueMap Unique Size -> UniqueMap Unique Size
forall a b. (a -> b) -> a -> b
$ UniqueMap Unique Size
forall a. Monoid a => a
mempty
bindingSizes
:: (HasUnique tyname TypeUnique, HasUnique name TermUnique)
=> Term tyname name uni fun ann -> PLC.UniqueMap Unique Size
bindingSizes :: forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Term tyname name uni fun ann -> UniqueMap Unique Size
bindingSizes (Let ann
_ Recursivity
_ NonEmpty (Binding tyname name uni fun ann)
binds Term tyname name uni fun ann
term) = (Binding tyname name uni fun ann -> UniqueMap Unique Size)
-> NonEmpty (Binding tyname name uni fun ann)
-> UniqueMap Unique Size
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Binding tyname name uni fun ann -> UniqueMap Unique Size
forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Binding tyname name uni fun ann -> UniqueMap Unique Size
bindingSize NonEmpty (Binding tyname name uni fun ann)
binds UniqueMap Unique Size
-> UniqueMap Unique Size -> UniqueMap Unique Size
forall a. Semigroup a => a -> a -> a
<> Term tyname name uni fun ann -> UniqueMap Unique Size
forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Term tyname name uni fun ann -> UniqueMap Unique Size
bindingSizes Term tyname name uni fun ann
term
bindingSizes Term tyname name uni fun ann
term = Term tyname name uni fun ann
term Term tyname name uni fun ann
-> Getting
(UniqueMap Unique Size)
(Term tyname name uni fun ann)
(UniqueMap Unique Size)
-> UniqueMap Unique Size
forall s a. s -> Getting a s a -> a
^. (Term tyname name uni fun ann
-> Const (UniqueMap Unique Size) (Term tyname name uni fun ann))
-> Term tyname name uni fun ann
-> Const (UniqueMap Unique Size) (Term tyname name uni fun ann)
forall tyname name (uni :: * -> *) fun a (f :: * -> *).
Applicative f =>
(Term tyname name uni fun a -> f (Term tyname name uni fun a))
-> Term tyname name uni fun a -> f (Term tyname name uni fun a)
termSubterms ((Term tyname name uni fun ann
-> Const (UniqueMap Unique Size) (Term tyname name uni fun ann))
-> Term tyname name uni fun ann
-> Const (UniqueMap Unique Size) (Term tyname name uni fun ann))
-> Getting
(UniqueMap Unique Size)
(Term tyname name uni fun ann)
(UniqueMap Unique Size)
-> Getting
(UniqueMap Unique Size)
(Term tyname name uni fun ann)
(UniqueMap Unique Size)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term tyname name uni fun ann -> UniqueMap Unique Size)
-> Getting
(UniqueMap Unique Size)
(Term tyname name uni fun ann)
(UniqueMap Unique Size)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Term tyname name uni fun ann -> UniqueMap Unique Size
forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Term tyname name uni fun ann -> UniqueMap Unique Size
bindingSizes
toDirectionRetentionMap
:: (HasUnique tyname TypeUnique, HasUnique name TermUnique)
=> Term tyname name uni fun ann -> DirectionRetentionMap
toDirectionRetentionMap :: forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Term tyname name uni fun ann -> DirectionRetentionMap
toDirectionRetentionMap Term tyname name uni fun ann
term =
IntMap Size -> DirectionRetentionMap
DirectionRetentionMap (IntMap Size -> DirectionRetentionMap)
-> (UniqueMap Unique Size -> IntMap Size)
-> UniqueMap Unique Size
-> DirectionRetentionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Size -> IntMap Size -> IntMap Size
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
rootInt Size
rootSize (IntMap Size -> IntMap Size)
-> (UniqueMap Unique Size -> IntMap Size)
-> UniqueMap Unique Size
-> IntMap Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqueMap Unique Size -> IntMap Size
forall unique a. UniqueMap unique a -> IntMap a
PLC.unUniqueMap (UniqueMap Unique Size -> DirectionRetentionMap)
-> UniqueMap Unique Size -> DirectionRetentionMap
forall a b. (a -> b) -> a -> b
$ Term tyname name uni fun ann -> UniqueMap Unique Size
forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Term tyname name uni fun ann -> UniqueMap Unique Size
bindingSizes Term tyname name uni fun ann
term where
rootSize :: Size
rootSize = Integer -> Size
Size (- Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
10::Int))
hasSizeIn :: DirectionRetentionMap -> Node -> Bool
hasSizeIn :: DirectionRetentionMap -> Node -> Bool
hasSizeIn DirectionRetentionMap
_ Node
Root = Bool
True
hasSizeIn (DirectionRetentionMap IntMap Size
ss) (Variable (PLC.Unique Int
i)) = Int
i Int -> IntMap Size -> Bool
forall a. Int -> IntMap a -> Bool
`IntMap.member` IntMap Size
ss
termRetentionMap
:: (HasUnique tyname TypeUnique, HasUnique name TermUnique, ToBuiltinMeaning uni fun)
=> BuiltinsInfo uni fun
-> VarsInfo tyname name uni ann
-> Term tyname name uni fun ann
-> IntMap Size
termRetentionMap :: forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique,
ToBuiltinMeaning uni fun) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni ann
-> Term tyname name uni fun ann
-> IntMap Size
termRetentionMap BuiltinsInfo uni fun
binfo VarsInfo tyname name uni ann
vinfo Term tyname name uni fun ann
term = DirectionRetentionMap -> Graph Node -> IntMap Size
depsRetentionMap DirectionRetentionMap
sizeInfo Graph Node
deps where
sizeInfo :: DirectionRetentionMap
sizeInfo = Term tyname name uni fun ann -> DirectionRetentionMap
forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique) =>
Term tyname name uni fun ann -> DirectionRetentionMap
toDirectionRetentionMap Term tyname name uni fun ann
term
deps :: Graph Node
deps = (Node -> Bool) -> Graph Node -> Graph Node
forall a. (a -> Bool) -> Graph a -> Graph a
C.induce (DirectionRetentionMap -> Node -> Bool
hasSizeIn DirectionRetentionMap
sizeInfo) (Graph Node -> Graph Node) -> Graph Node -> Graph Node
forall a b. (a -> b) -> a -> b
$ BuiltinsInfo uni fun
-> VarsInfo tyname name uni ann
-> Term tyname name uni fun ann
-> Graph Node
forall g tyname name (uni :: * -> *) fun a.
(DepGraph g, HasUnique tyname TypeUnique,
HasUnique name TermUnique, ToBuiltinMeaning uni fun) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni a -> Term tyname name uni fun a -> g
runTermDeps BuiltinsInfo uni fun
binfo VarsInfo tyname name uni ann
vinfo Term tyname name uni fun ann
term
reannotateBindings
:: (HasUnique name TermUnique, HasUnique tyname TypeUnique)
=> (Unique -> ann -> ann)
-> Term tyname name uni fun ann
-> Term tyname name uni fun ann
reannotateBindings :: forall name tyname ann (uni :: * -> *) fun.
(HasUnique name TermUnique, HasUnique tyname TypeUnique) =>
(Unique -> ann -> ann)
-> Term tyname name uni fun ann -> Term tyname name uni fun ann
reannotateBindings Unique -> ann -> ann
f = Term tyname name uni fun ann -> Term tyname name uni fun ann
forall {unique} {unique} {tyname} {name} {uni :: * -> *} {fun}.
(Coercible unique Int, Coercible unique Int,
HasUnique tyname unique, HasUnique name unique) =>
Term tyname name uni fun ann -> Term tyname name uni fun ann
goTerm where
goVarDecl :: VarDecl tyname name uni ann -> VarDecl tyname name uni ann
goVarDecl (VarDecl ann
ann name
name Type tyname uni ann
ty) = ann -> name -> Type tyname uni ann -> VarDecl tyname name uni ann
forall tyname name (uni :: * -> *) ann.
ann -> name -> Type tyname uni ann -> VarDecl tyname name uni ann
VarDecl (Unique -> ann -> ann
f (name
name name -> Getting Unique name Unique -> Unique
forall s a. s -> Getting a s a -> a
^. Getting Unique name Unique
forall name unique. HasUnique name unique => Lens' name Unique
Lens' name Unique
theUnique) ann
ann) name
name Type tyname uni ann
ty
goTyVarDecl :: TyVarDecl tyname ann -> TyVarDecl tyname ann
goTyVarDecl (TyVarDecl ann
ann tyname
tyname Kind ann
kind) = ann -> tyname -> Kind ann -> TyVarDecl tyname ann
forall tyname ann.
ann -> tyname -> Kind ann -> TyVarDecl tyname ann
TyVarDecl (Unique -> ann -> ann
f (tyname
tyname tyname -> Getting Unique tyname Unique -> Unique
forall s a. s -> Getting a s a -> a
^. Getting Unique tyname Unique
forall name unique. HasUnique name unique => Lens' name Unique
Lens' tyname Unique
theUnique) ann
ann) tyname
tyname Kind ann
kind
goDatatype :: Datatype tyname name uni ann -> Datatype tyname name uni ann
goDatatype (Datatype ann
ann TyVarDecl tyname ann
dataTyDecl [TyVarDecl tyname ann]
paramTyDecls name
matchName [VarDecl tyname name uni ann]
constrDecls) =
ann
-> TyVarDecl tyname ann
-> [TyVarDecl tyname ann]
-> name
-> [VarDecl tyname name uni ann]
-> Datatype tyname name uni ann
forall tyname name (uni :: * -> *) a.
a
-> TyVarDecl tyname a
-> [TyVarDecl tyname a]
-> name
-> [VarDecl tyname name uni a]
-> Datatype tyname name uni a
Datatype
(Unique -> ann -> ann
f (name
matchName name -> Getting Unique name Unique -> Unique
forall s a. s -> Getting a s a -> a
^. Getting Unique name Unique
forall name unique. HasUnique name unique => Lens' name Unique
Lens' name Unique
theUnique) ann
ann)
(TyVarDecl tyname ann -> TyVarDecl tyname ann
forall {unique} {tyname}.
(Coercible unique Int, HasUnique tyname unique) =>
TyVarDecl tyname ann -> TyVarDecl tyname ann
goTyVarDecl TyVarDecl tyname ann
dataTyDecl)
(TyVarDecl tyname ann -> TyVarDecl tyname ann
forall {unique} {tyname}.
(Coercible unique Int, HasUnique tyname unique) =>
TyVarDecl tyname ann -> TyVarDecl tyname ann
goTyVarDecl (TyVarDecl tyname ann -> TyVarDecl tyname ann)
-> [TyVarDecl tyname ann] -> [TyVarDecl tyname ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarDecl tyname ann]
paramTyDecls)
name
matchName
(VarDecl tyname name uni ann -> VarDecl tyname name uni ann
forall {unique} {name} {tyname} {uni :: * -> *}.
(Coercible unique Int, HasUnique name unique) =>
VarDecl tyname name uni ann -> VarDecl tyname name uni ann
goVarDecl (VarDecl tyname name uni ann -> VarDecl tyname name uni ann)
-> [VarDecl tyname name uni ann] -> [VarDecl tyname name uni ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarDecl tyname name uni ann]
constrDecls)
goBind :: Binding tyname name uni fun ann -> Binding tyname name uni fun ann
goBind (TermBind ann
ann Strictness
str VarDecl tyname name uni ann
var Term tyname name uni fun ann
term) = ann
-> Strictness
-> VarDecl tyname name uni ann
-> Term tyname name uni fun ann
-> Binding tyname name uni fun ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
TermBind ann
ann Strictness
str (VarDecl tyname name uni ann -> VarDecl tyname name uni ann
forall {unique} {name} {tyname} {uni :: * -> *}.
(Coercible unique Int, HasUnique name unique) =>
VarDecl tyname name uni ann -> VarDecl tyname name uni ann
goVarDecl VarDecl tyname name uni ann
var) (Term tyname name uni fun ann -> Binding tyname name uni fun ann)
-> Term tyname name uni fun ann -> Binding tyname name uni fun ann
forall a b. (a -> b) -> a -> b
$ Term tyname name uni fun ann -> Term tyname name uni fun ann
goTerm Term tyname name uni fun ann
term
goBind (TypeBind ann
ann TyVarDecl tyname ann
tyVar Type tyname uni ann
ty) = ann
-> TyVarDecl tyname ann
-> Type tyname uni ann
-> Binding tyname name uni fun ann
forall tyname name (uni :: * -> *) fun a.
a
-> TyVarDecl tyname a
-> Type tyname uni a
-> Binding tyname name uni fun a
TypeBind ann
ann (TyVarDecl tyname ann -> TyVarDecl tyname ann
forall {unique} {tyname}.
(Coercible unique Int, HasUnique tyname unique) =>
TyVarDecl tyname ann -> TyVarDecl tyname ann
goTyVarDecl TyVarDecl tyname ann
tyVar) Type tyname uni ann
ty
goBind (DatatypeBind ann
ann Datatype tyname name uni ann
datatype) = ann
-> Datatype tyname name uni ann -> Binding tyname name uni fun ann
forall tyname name (uni :: * -> *) fun a.
a -> Datatype tyname name uni a -> Binding tyname name uni fun a
DatatypeBind ann
ann (Datatype tyname name uni ann -> Binding tyname name uni fun ann)
-> Datatype tyname name uni ann -> Binding tyname name uni fun ann
forall a b. (a -> b) -> a -> b
$ Datatype tyname name uni ann -> Datatype tyname name uni ann
forall {unique} {unique} {tyname} {name} {uni :: * -> *}.
(Coercible unique Int, Coercible unique Int,
HasUnique tyname unique, HasUnique name unique) =>
Datatype tyname name uni ann -> Datatype tyname name uni ann
goDatatype Datatype tyname name uni ann
datatype
goTerm :: Term tyname name uni fun ann -> Term tyname name uni fun ann
goTerm (Let ann
ann Recursivity
recy NonEmpty (Binding tyname name uni fun ann)
binds Term tyname name uni fun ann
term) = ann
-> Recursivity
-> NonEmpty (Binding tyname name uni fun ann)
-> Term tyname name uni fun ann
-> Term tyname name uni fun ann
forall tyname name (uni :: * -> *) fun a.
a
-> Recursivity
-> NonEmpty (Binding tyname name uni fun a)
-> Term tyname name uni fun a
-> Term tyname name uni fun a
Let ann
ann Recursivity
recy (Binding tyname name uni fun ann -> Binding tyname name uni fun ann
goBind (Binding tyname name uni fun ann
-> Binding tyname name uni fun ann)
-> NonEmpty (Binding tyname name uni fun ann)
-> NonEmpty (Binding tyname name uni fun ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Binding tyname name uni fun ann)
binds) (Term tyname name uni fun ann -> Term tyname name uni fun ann)
-> Term tyname name uni fun ann -> Term tyname name uni fun ann
forall a b. (a -> b) -> a -> b
$ Term tyname name uni fun ann -> Term tyname name uni fun ann
goTerm Term tyname name uni fun ann
term
goTerm Term tyname name uni fun ann
term = Term tyname name uni fun ann
term Term tyname name uni fun ann
-> (Term tyname name uni fun ann -> Term tyname name uni fun ann)
-> Term tyname name uni fun ann
forall a b. a -> (a -> b) -> b
& (Term tyname name uni fun ann
-> Identity (Term tyname name uni fun ann))
-> Term tyname name uni fun ann
-> Identity (Term tyname name uni fun ann)
forall tyname name (uni :: * -> *) fun a (f :: * -> *).
Applicative f =>
(Term tyname name uni fun a -> f (Term tyname name uni fun a))
-> Term tyname name uni fun a -> f (Term tyname name uni fun a)
termSubterms ((Term tyname name uni fun ann
-> Identity (Term tyname name uni fun ann))
-> Term tyname name uni fun ann
-> Identity (Term tyname name uni fun ann))
-> (Term tyname name uni fun ann -> Term tyname name uni fun ann)
-> Term tyname name uni fun ann
-> Term tyname name uni fun ann
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Term tyname name uni fun ann -> Term tyname name uni fun ann
goTerm
annotateWithRetainedSize
:: (HasUnique name TermUnique, HasUnique tyname TypeUnique, ToBuiltinMeaning uni fun)
=> BuiltinsInfo uni fun
-> Term tyname name uni fun ann
-> Term tyname name uni fun RetainedSize
annotateWithRetainedSize :: forall name tyname (uni :: * -> *) fun ann.
(HasUnique name TermUnique, HasUnique tyname TypeUnique,
ToBuiltinMeaning uni fun) =>
BuiltinsInfo uni fun
-> Term tyname name uni fun ann
-> Term tyname name uni fun RetainedSize
annotateWithRetainedSize BuiltinsInfo uni fun
binfo Term tyname name uni fun ann
term = (Unique -> RetainedSize -> RetainedSize)
-> Term tyname name uni fun RetainedSize
-> Term tyname name uni fun RetainedSize
forall name tyname ann (uni :: * -> *) fun.
(HasUnique name TermUnique, HasUnique tyname TypeUnique) =>
(Unique -> ann -> ann)
-> Term tyname name uni fun ann -> Term tyname name uni fun ann
reannotateBindings (Int -> RetainedSize -> RetainedSize
forall {p}. Int -> p -> RetainedSize
upd (Int -> RetainedSize -> RetainedSize)
-> (Unique -> Int) -> Unique -> RetainedSize -> RetainedSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
unUnique) (Term tyname name uni fun RetainedSize
-> Term tyname name uni fun RetainedSize)
-> Term tyname name uni fun RetainedSize
-> Term tyname name uni fun RetainedSize
forall a b. (a -> b) -> a -> b
$ RetainedSize
NotARetainer RetainedSize
-> Term tyname name uni fun ann
-> Term tyname name uni fun RetainedSize
forall a b.
a -> Term tyname name uni fun b -> Term tyname name uni fun a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Term tyname name uni fun ann
term where
retentionMap :: IntMap Size
retentionMap = BuiltinsInfo uni fun
-> VarsInfo tyname name uni ann
-> Term tyname name uni fun ann
-> IntMap Size
forall tyname name (uni :: * -> *) fun ann.
(HasUnique tyname TypeUnique, HasUnique name TermUnique,
ToBuiltinMeaning uni fun) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni ann
-> Term tyname name uni fun ann
-> IntMap Size
termRetentionMap BuiltinsInfo uni fun
binfo VarsInfo tyname name uni ann
vinfo Term tyname name uni fun ann
term
vinfo :: VarsInfo tyname name uni ann
vinfo = Term tyname name uni fun ann -> VarsInfo tyname name uni ann
forall name tyname (uni :: * -> *) fun a.
(HasUnique name TermUnique, HasUnique tyname TypeUnique) =>
Term tyname name uni fun a -> VarsInfo tyname name uni a
termVarInfo Term tyname name uni fun ann
term
upd :: Int -> p -> RetainedSize
upd Int
i p
_ = Size -> RetainedSize
Retains (Size -> RetainedSize) -> Size -> RetainedSize
forall a b. (a -> b) -> a -> b
$ Size -> Int -> IntMap Size -> Size
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault (Integer -> Size
Size Integer
0) Int
i IntMap Size
retentionMap