-
Notifications
You must be signed in to change notification settings - Fork 463
/
Parser.hs
129 lines (107 loc) · 4.78 KB
/
Parser.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Parser for untyped Plutus Core using megaparsec, as in Plutus IR.
-- Will replace UntypedPlutusCore.Parser.hs.
-- Parser.y and Lexer.x, which currently generate Parser.hs, will be removed.
module UntypedPlutusCore.Parser
( parse
, parseQuoted
, term
, program
, parseTerm
, parseProgram
, parseScoped
, Parser
, SourcePos
) where
import Prelude hiding (fail)
import Control.Monad.Except ((<=<))
import Control.Monad.State (StateT)
import PlutusCore qualified as PLC
import PlutusCore.Parsable qualified as PLC
import PlutusPrelude (Pretty, through)
import Text.Megaparsec hiding (ParseError, State, parse)
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Check.Uniques (checkProgram)
import UntypedPlutusCore.Rename (Rename (rename))
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy.Internal (unpackChars)
import Data.Text qualified as T
import PlutusCore.Parser.ParserCommon
-- Parsers for UPLC terms
conTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
conTerm = inParens $ UPLC.Constant <$> wordPos "con" <*> constant
builtinTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
builtinTerm = inParens $ UPLC.Builtin <$> wordPos "builtin" <*> builtinFunction
varTerm :: Parser (UPLC.Term PLC.Name uni fun SourcePos)
varTerm = UPLC.Var <$> getSourcePos <*> name
lamTerm :: ParsecT PLC.ParseError
T.Text
(StateT ParserState PLC.Quote)
(UPLC.Term PLC.Name uni fun SourcePos)
-> Parser (UPLC.Term PLC.Name uni fun SourcePos)
lamTerm tm = inParens $ UPLC.LamAbs <$> wordPos "lam" <*> name <*> tm
appTerm :: ParsecT PLC.ParseError
T.Text
(StateT ParserState PLC.Quote)
(UPLC.Term PLC.Name uni fun SourcePos)
-> Parser (UPLC.Term PLC.Name uni fun SourcePos)
appTerm tm = inBrackets $ UPLC.Apply <$> getSourcePos <*> tm <*> tm
delayTerm :: ParsecT PLC.ParseError
T.Text
(StateT ParserState PLC.Quote)
(UPLC.Term PLC.Name uni fun SourcePos)
-> Parser (UPLC.Term PLC.Name uni fun SourcePos)
delayTerm tm = inParens $ UPLC.Delay <$> wordPos "abs" <*> tm
forceTerm :: ParsecT PLC.ParseError
T.Text
(StateT ParserState PLC.Quote)
(UPLC.Term PLC.Name uni fun SourcePos)
-> Parser (UPLC.Term PLC.Name uni fun SourcePos)
forceTerm tm = inBraces $ UPLC.Force <$> getSourcePos <*> tm
errorTerm
:: Parser (UPLC.Term PLC.Name uni fun SourcePos)
errorTerm = inParens $ UPLC.Error <$> wordPos "error"
-- | Parser for all UPLC terms.
term :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
term = conTerm
<|> builtinTerm
<|> varTerm
<|> lamTerm self
<|> appTerm self
<|> delayTerm self
<|> forceTerm self
<|> errorTerm
where self = term
-- | Parser for UPLC programs.
program :: Parser (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
program = whitespace >> do
prog <- inParens $ UPLC.Program <$> wordPos "program" <*> version <*> term
notFollowedBy anySingle
return prog
-- | Generic parser function.
parseGen :: Parser a -> ByteString -> Either (ParseErrorBundle T.Text PLC.ParseError) a
parseGen stuff bs = parse stuff "test" $ (T.pack . unpackChars) bs
-- | Parse a PLC term. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
parseTerm :: ByteString ->
Either (ParseErrorBundle T.Text PLC.ParseError) (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
parseTerm = parseGen term
-- | Parse a PLC program. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
parseProgram :: ByteString ->
Either (ParseErrorBundle T.Text PLC.ParseError) (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
parseProgram = parseGen program
-- | Parse and rewrite so that names are globally unique, not just unique within
-- their scope.
parseScoped ::
(PLC.MonadQuote (Either (ParseErrorBundle T.Text PLC.ParseError)),
PLC.AsUniqueError (ParseErrorBundle T.Text PLC.ParseError) SourcePos)
=> ByteString
-> Either (ParseErrorBundle T.Text PLC.ParseError) (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
-- don't require there to be no free variables at this point, we might be parsing an open term
parseScoped = through (checkProgram (const True)) <=< rename <=< parseProgram