Skip to content

Commit 747f534

Browse files
SeungheonOhSeungheonOh
committed
wip
1 parent 119a64e commit 747f534

File tree

10 files changed

+95
-21
lines changed

10 files changed

+95
-21
lines changed

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import PlutusCore.Name.Unique (HasUnique, TermUnique (TermUnique), Unique (Uniqu
1616
import Control.Lens (forMOf_)
1717
import Control.Monad.State (MonadState, execStateT)
1818
import Control.Monad.Writer (MonadWriter, WriterT (runWriterT))
19+
import Data.Foldable (traverse_)
1920

2021
-- | Given a UPLC term, add all of its term definitions and usages, including its subterms,
2122
-- to a global map.
@@ -40,6 +41,8 @@ handleTerm = \case
4041
addUsage n ann TermScope
4142
LamAbs ann n _ ->
4243
addDef n ann TermScope
44+
Let ann ns _ ->
45+
traverse_ (\n -> addDef n ann TermScope) ns
4346
_ -> pure ()
4447

4548
runTermDefs

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs‎

Lines changed: 21 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ tags and their used/available encoding possibilities.
6565
| Data type | Function | Bit Width | Total | Used | Remaining |
6666
|------------------|-------------------|-----------|-------|------|-----------|
6767
| default builtins | encodeBuiltin | 7 | 128 | 54 | 74 |
68-
| Terms | encodeTerm | 4 | 16 | 10 | 6 |
68+
| Terms | encodeTerm | 4 | 16 | 10 | 4 |
6969
7070
For format stability we are manually assigning the tag values to the
7171
constructors (and we do not use a generic algorithm that may change this order).
@@ -114,16 +114,18 @@ encodeTerm
114114
=> Term name uni fun ann
115115
-> Encoding
116116
encodeTerm = \case
117-
Var ann n -> encodeTermTag 0 <> encode ann <> encode n
118-
Delay ann t -> encodeTermTag 1 <> encode ann <> encodeTerm t
119-
LamAbs ann n t -> encodeTermTag 2 <> encode ann <> encode (Binder n) <> encodeTerm t
120-
Apply ann t t' -> encodeTermTag 3 <> encode ann <> encodeTerm t <> encodeTerm t'
121-
Constant ann c -> encodeTermTag 4 <> encode ann <> encode c
122-
Force ann t -> encodeTermTag 5 <> encode ann <> encodeTerm t
123-
Error ann -> encodeTermTag 6 <> encode ann
124-
Builtin ann bn -> encodeTermTag 7 <> encode ann <> encode bn
125-
Constr ann i es -> encodeTermTag 8 <> encode ann <> encode i <> encodeListWith encodeTerm es
126-
Case ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm (V.toList cs)
117+
Var ann n -> encodeTermTag 0 <> encode ann <> encode n
118+
Delay ann t -> encodeTermTag 1 <> encode ann <> encodeTerm t
119+
LamAbs ann n t -> encodeTermTag 2 <> encode ann <> encode (Binder n) <> encodeTerm t
120+
Apply ann t t' -> encodeTermTag 3 <> encode ann <> encodeTerm t <> encodeTerm t'
121+
Constant ann c -> encodeTermTag 4 <> encode ann <> encode c
122+
Force ann t -> encodeTermTag 5 <> encode ann <> encodeTerm t
123+
Error ann -> encodeTermTag 6 <> encode ann
124+
Builtin ann bn -> encodeTermTag 7 <> encode ann <> encode bn
125+
Constr ann i es -> encodeTermTag 8 <> encode ann <> encode i <> encodeListWith encodeTerm es
126+
Case ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm (V.toList cs)
127+
Let ann ns t -> encodeTermTag 10 <> encode ann <> encode ns <> encodeTerm t
128+
Bind ann t bs -> encodeTermTag 11 <> encode ann <> encodeTerm t <> encodeListWith encodeTerm bs
127129

128130
decodeTerm
129131
:: forall name uni fun ann
@@ -161,6 +163,12 @@ decodeTerm version builtinPred = go
161163
handleTerm 9 = do
162164
unless (version >= PLC.plcVersion110) $ fail $ "'case' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version)
163165
Case <$> decode <*> go <*> (V.fromList <$> decodeListWith go)
166+
handleTerm 10 = do
167+
-- TODO: fail when version is low
168+
Let <$> decode <*> decode <*> go
169+
handleTerm 11 = do
170+
-- TODO: fail when version is low
171+
Bind <$> decode <*> go <*> decodeListWith go
164172
handleTerm t = fail $ "Unknown term constructor tag: " ++ show t
165173

166174
sizeTerm
@@ -189,6 +197,8 @@ sizeTerm tm sz =
189197
Builtin ann bn -> size ann $ size bn sz'
190198
Constr ann i es -> size ann $ size i $ sizeListWith sizeTerm es sz'
191199
Case ann arg cs -> size ann $ sizeTerm arg $ sizeListWith sizeTerm (V.toList cs) sz'
200+
Let ann ns t -> size ann $ size ns $ sizeTerm t sz'
201+
Bind ann t bs -> size ann $ sizeTerm t $ sizeListWith sizeTerm bs sz'
192202

193203
-- | An encoder for programs.
194204
--

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,14 @@ instance (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann
5050
Case ann arg cs ->
5151
sexp "case" (consAnnIf config ann
5252
(prettyBy config arg : fmap (prettyBy config) (toList cs)))
53+
Let ann names body ->
54+
sexp "let" (consAnnIf config ann
55+
[ parens' (sep $ prettyBy config <$> names)
56+
, prettyBy config body
57+
])
58+
Bind ann t binds ->
59+
sexp "bind" (consAnnIf config ann
60+
(prettyBy config t : (prettyBy config <$> binds)))
5361
where
5462
prettyTypeOf :: Some (ValueOf uni) -> Doc dann
5563
prettyTypeOf (Some (ValueOf uni _ )) = prettyBy juxtRenderContext $ SomeTypeIn uni

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs‎

Lines changed: 14 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,8 @@ termConstants f term0 = case term0 of
3232
Builtin{} -> pure term0
3333
Constr{} -> pure term0
3434
Case{} -> pure term0
35+
Let{} -> pure term0
36+
Bind{} -> pure term0
3537

3638
-- | Get all the direct child 'name a's of the given 'Term' from 'LamAbs'es.
3739
termBinds :: Traversal' (Term name uni fun ann) name
@@ -55,16 +57,18 @@ termUniques f = \case
5557
-- | Get all the direct child 'Term's of the given 'Term'.
5658
termSubterms :: Traversal' (Term name uni fun ann) (Term name uni fun ann)
5759
termSubterms f = \case
58-
LamAbs ann n t -> LamAbs ann n <$> f t
59-
Apply ann t1 t2 -> Apply ann <$> f t1 <*> f t2
60-
Delay ann t -> Delay ann <$> f t
61-
Force ann t -> Force ann <$> f t
62-
Constr ann i args -> Constr ann i <$> traverse f args
63-
Case ann arg cs -> Case ann <$> f arg <*> traverse f cs
64-
e@Error {} -> pure e
65-
v@Var {} -> pure v
66-
c@Constant {} -> pure c
67-
b@Builtin {} -> pure b
60+
LamAbs ann n t -> LamAbs ann n <$> f t
61+
Apply ann t1 t2 -> Apply ann <$> f t1 <*> f t2
62+
Delay ann t -> Delay ann <$> f t
63+
Force ann t -> Force ann <$> f t
64+
Constr ann i args -> Constr ann i <$> traverse f args
65+
Case ann arg cs -> Case ann <$> f arg <*> traverse f cs
66+
Let ann names body -> Let ann names <$> f body
67+
Bind ann t binds -> Bind ann <$> f t <*> traverse f binds
68+
e@Error {} -> pure e
69+
v@Var {} -> pure v
70+
c@Constant {} -> pure c
71+
b@Builtin {} -> pure b
6872
{-# INLINE termSubterms #-}
6973

7074
-- | Get all the transitive child 'Constant's of the given 'Term'.

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -101,6 +101,8 @@ data Term name uni fun ann
101101
| Constr !ann !Word64 ![Term name uni fun ann]
102102
-- See Note [Supported case-expressions].
103103
| Case !ann !(Term name uni fun ann) !(Vector (Term name uni fun ann))
104+
| Let !ann ![name] !(Term name uni fun ann)
105+
| Bind !ann !(Term name uni fun ann) ![Term name uni fun ann]
104106
deriving stock (Functor, Generic)
105107

106108
deriving stock instance (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni)
@@ -168,6 +170,8 @@ termAnn (Force ann _) = ann
168170
termAnn (Error ann) = ann
169171
termAnn (Constr ann _ _) = ann
170172
termAnn (Case ann _ _) = ann
173+
termAnn (Let ann _ _) = ann
174+
termAnn (Bind ann _ _) = ann
171175

172176
bindFunM
173177
:: Monad m
@@ -185,6 +189,8 @@ bindFunM f = go where
185189
go (Error ann) = pure $ Error ann
186190
go (Constr ann i args) = Constr ann i <$> traverse go args
187191
go (Case ann arg cs) = Case ann <$> go arg <*> traverse go cs
192+
go (Let ann name body) = Let ann name <$> go body
193+
go (Bind ann fun arg) = Bind ann <$> go fun <*> traverse go arg
188194

189195
bindFun
190196
:: (ann -> fun -> Term name uni fun' ann)

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -93,6 +93,15 @@ deBruijnTermWithM h = go
9393
Constant ann con -> pure $ Constant ann con
9494
Builtin ann bn -> pure $ Builtin ann bn
9595
Error ann -> pure $ Error ann
96+
Let ann names body -> do
97+
let
98+
goNames acc [] = Let ann (acc []) <$> go body
99+
goNames acc (n:ns) = declareUnique n $ do
100+
n' <- nameToDeBruijn h n
101+
withScope $ do
102+
goNames (acc . (n':)) ns
103+
goNames id names
104+
Bind ann t binds -> Bind ann <$> go t <*> traverse go binds
96105

97106
-- | Takes a "handler" function to execute when encountering free variables.
98107
unDeBruijnTermWithM
@@ -121,3 +130,12 @@ unDeBruijnTermWithM h = go
121130
Constant ann con -> pure $ Constant ann con
122131
Builtin ann bn -> pure $ Builtin ann bn
123132
Error ann -> pure $ Error ann
133+
Let ann names body -> do
134+
let
135+
goNames acc [] = Let ann (acc []) <$> go body
136+
goNames acc (n:ns) = declareBinder $ do
137+
n' <- deBruijnToName h $ set index deBruijnInitIndex n
138+
withScope $ do
139+
goNames (acc . (n':)) ns
140+
goNames id names
141+
Bind ann t binds -> Bind ann <$> go t <*> traverse go binds

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -308,6 +308,7 @@ data CekValue uni fun ann =
308308
-- Check the docs of 'BuiltinRuntime' for details.
309309
-- | A constructor value, including fully computed arguments and the tag.
310310
| VConstr {-# UNPACK #-} !Word64 !(EmptyOrMultiStack uni fun ann)
311+
| VBinds !(ArgStackNonEmpty uni fun ann)
311312

312313
deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni)
313314
=> Show (CekValue uni fun ann)

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -90,6 +90,20 @@ caseTerm = withSpan $ \sp ->
9090
whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0"
9191
pure res
9292

93+
letTerm :: Parser PTerm
94+
letTerm = withSpan $ \sp ->
95+
inParens $ symbol "let" *> do
96+
res <- UPLC.Let sp <$> (inParens $ many (leadingWhitespace name)) <*> term
97+
-- TODO: version check
98+
pure res
99+
100+
bindTerm :: Parser PTerm
101+
bindTerm = withSpan $ \sp ->
102+
inParens $ symbol "bind" *> do
103+
res <- UPLC.Bind sp <$> term <*> (many term)
104+
-- TODO: version check
105+
pure res
106+
93107
-- | Parser for all UPLC terms.
94108
term :: Parser PTerm
95109
term = leadingWhitespace go
@@ -106,6 +120,8 @@ term = leadingWhitespace go
106120
, errorTerm
107121
, constrTerm
108122
, caseTerm
123+
, letTerm
124+
, bindTerm
109125
]
110126

111127
-- | Parser for UPLC programs.

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,12 @@ renameTermM (Constr ann i es) = Constr ann i <$> traverse renameTermM e
3535
renameTermM (Case ann arg cs) = Case ann <$> renameTermM arg <*> traverse renameTermM cs
3636
renameTermM con@Constant{} = pure con
3737
renameTermM bi@Builtin{} = pure bi
38+
renameTermM (Let ann names body) =
39+
let
40+
goNames acc [] = Let ann (acc []) <$> renameTermM body
41+
goNames acc (n:ns) = withFreshenedName n $ \n' -> goNames (acc . (n':)) ns
42+
in goNames id names
43+
renameTermM (Bind ann t binds) = Bind ann <$> renameTermM t <*> traverse renameTermM binds
3844

3945
-- | Rename a 'Program' in the 'RenameM' monad.
4046
renameProgramM

‎plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,8 @@ termMapNames f = go
7272
Force ann t -> Force ann (go t)
7373
Constr ann i es -> Constr ann i (fmap go es)
7474
Case ann arg cs -> Case ann (go arg) (fmap go cs)
75+
Let ann ns t -> Let ann (fmap f ns) (go t)
76+
Bind ann t bs -> Bind ann (go t) (fmap go bs)
7577

7678
Constant ann c -> Constant ann c
7779
Builtin ann b -> Builtin ann b

0 commit comments

Comments
 (0)