-
Notifications
You must be signed in to change notification settings - Fork 463
/
Parser.hs
125 lines (104 loc) · 3.77 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
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module PlutusCore.Parser
( parseProgram
, parseTerm
, parseType
, ParseError(..)
) where
import Data.ByteString.Lazy (ByteString)
import Data.Text qualified as T
import PlutusCore.Core (Program (..), Term (..), Type)
import PlutusCore.Default (DefaultFun, DefaultUni)
import PlutusCore.Error (ParseError (..))
import PlutusCore.Name (Name, TyName)
import PlutusCore.Parser.ParserCommon
import Text.Megaparsec (MonadParsec (notFollowedBy), SourcePos, anySingle, choice, getSourcePos, try)
import Text.Megaparsec.Error (ParseErrorBundle)
-- Parsers for PLC terms
-- | A parsable PLC term.
type PTerm = Term TyName Name DefaultUni DefaultFun SourcePos
varTerm :: Parser PTerm
varTerm = Var <$> getSourcePos <*> name
tyAbsTerm :: Parser PTerm
tyAbsTerm = inParens $ TyAbs <$> wordPos "abs" <*> tyName <*> kind <*> term
lamTerm :: Parser PTerm
lamTerm = inParens $ LamAbs <$> wordPos "lam" <*> name <*> pType <*> term
appTerm :: Parser PTerm
appTerm = inBrackets $ do
pos <- getSourcePos
tm <- term
tms <- appTerms
pure $ app pos tm tms
app :: SourcePos -> PTerm -> [PTerm] -> PTerm
app _ _t [] = error "appTerm, app: An application without the argument."
app loc t [t'] = Apply loc t t'
app loc t (t' : ts) = Apply loc (app loc t (t':init ts)) (last ts)
-- | The syntax allows @(app (app x y) z)@ to be written as [x y z]
-- rather than [[x y] z]. This deals with more than one application.
appTerms :: Parser [PTerm]
appTerms = choice
[ try terms
, do
tm <- term
pure [tm]
]
where terms = do
tm <- term
tms <- appTerms
pure $ tm : tms
-- | Parser for a constant term. Currently the syntax is "con defaultUniType val".
conTerm :: Parser PTerm
conTerm = inParens $ do
p <- wordPos "con"
_conTy <- defaultUniType -- TODO: do case of for each ty?
con <- constant
pure $ Constant p con
builtinTerm :: Parser PTerm
builtinTerm = inParens $ Builtin <$> wordPos "builtin" <*> builtinFunction
tyInstTerm :: Parser PTerm
tyInstTerm = inBraces $ TyInst <$> getSourcePos <*> term <*> pType
unwrapTerm :: Parser PTerm
unwrapTerm = inParens $ Unwrap <$> wordPos "unwrap" <*> term
iwrapTerm :: Parser PTerm
iwrapTerm = inParens $ IWrap <$> wordPos "iwrap" <*> pType <*> pType <*> term
errorTerm
:: Parser PTerm
errorTerm = inParens $ Error <$> wordPos "error" <*> pType
-- | Parser for all PLC terms.
term :: Parser PTerm
term = choice $ map try
[ tyAbsTerm
, lamTerm
, appTerm
, conTerm
, builtinTerm
, tyInstTerm
, unwrapTerm
, iwrapTerm
, errorTerm
, varTerm
]
-- | 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 ParseError) (Program TyName Name DefaultUni DefaultFun SourcePos)
parseProgram = parseGen program
-- | Parser for PLC programs.
program :: Parser (Program TyName Name DefaultUni DefaultFun SourcePos)
program = whitespace >> do
prog <- inParens $ Program <$> wordPos "program" <*> version <*> term
notFollowedBy anySingle
return prog
-- | 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 ParseError) (Term TyName Name DefaultUni DefaultFun SourcePos)
parseTerm = parseGen term
-- | Parse a PLC type. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
parseType ::
ByteString ->
Either (ParseErrorBundle T.Text ParseError) (Type TyName DefaultUni SourcePos)
parseType = parseGen pType