-
Notifications
You must be signed in to change notification settings - Fork 461
/
Parser.y
203 lines (161 loc) · 8.27 KB
/
Parser.y
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
{
{-# LANGUAGE OverloadedStrings #-}
module Language.PlutusCore.Parser ( parse
, parseTm
, parseTy
, parseST
, parseTermST
, parseTypeST
, parseProgram
, parseTerm
, parseType
, ParseError (..)
) where
import PlutusPrelude
import Language.PlutusCore.Error
import Language.PlutusCore.Lexer.Type
import Language.PlutusCore.Lexer
import Language.PlutusCore.Quote
import Language.PlutusCore.Core
import Language.PlutusCore.Name
import Language.PlutusCore.Mark
import Language.PlutusCore.Constant.Make
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc.Internal (Doc (Text))
import Control.Monad.Except
import Control.Monad.State
}
%name parsePlutusCoreProgram Program
%name parsePlutusCoreTerm Term
%name parsePlutusCoreType Type
%tokentype { Token AlexPosn }
%error { parseError }
%monad { Parse } { (>>=) } { pure }
%lexer { lift alexMonadScan >>= } { EOF _ }
%nonassoc integer
%nonassoc float
%nonassoc bytestring
%nonassoc iwrap
%nonassoc unwrap
%nonassoc lam
%nonassoc con
%nonassoc bi
%token
abs { LexKeyword $$ KwAbs }
lam { LexKeyword $$ KwLam }
ifix { LexKeyword $$ KwIFix }
con { LexKeyword $$ KwCon }
builtin { LexKeyword $$ KwBuiltin }
fun { LexKeyword $$ KwFun }
all { LexKeyword $$ KwAll }
integer { LexKeyword $$ KwInteger }
bytestring { LexKeyword $$ KwByteString }
type { LexKeyword $$ KwType }
program { LexKeyword $$ KwProgram }
iwrap { LexKeyword $$ KwIWrap }
unwrap { LexKeyword $$ KwUnwrap }
errorTerm { LexKeyword $$ KwError }
openParen { LexSpecial $$ OpenParen }
closeParen { LexSpecial $$ CloseParen }
openBracket { LexSpecial $$ OpenBracket }
closeBracket { LexSpecial $$ CloseBracket }
dot { LexSpecial $$ Dot }
openBrace { LexSpecial $$ OpenBrace }
closeBrace { LexSpecial $$ CloseBrace }
builtinVar { $$@LexBuiltin{} }
integerLit { $$@LexInt{} }
naturalLit { $$@LexNat{} }
byteStringLit { $$@LexBS{} }
var { $$@LexName{} }
%%
many(p)
: many(p) p { $2 : $1 }
| { [] }
some(p)
: some(p) p { $2 :| toList $1 }
| p { $1 :| [] }
parens(p)
: openParen p closeParen { $2 }
Program : openParen program Version Term closeParen { Program $2 $3 $4 }
Version : naturalLit dot naturalLit dot naturalLit { Version (tkLoc $1) (tkNat $1) (tkNat $3) (tkNat $5) }
Constant : integerLit {% handleInteger (tkLoc $1) (tkInt $1) }
| naturalLit {% handleInteger (tkLoc $1) (fromIntegral (tkNat $1)) }
| byteStringLit { BuiltinBS (tkLoc $1) (tkBytestring $1) } -- this is kinda broken but I'm waiting for a new spec
Name : var { Name (tkLoc $1) (tkName $1) (tkIdentifier $1) }
TyName : Name { TyName $1 }
Term : Name { Var (nameAttribute $1) $1 }
| openParen abs TyName Kind Term closeParen { TyAbs $2 $3 $4 $5 }
| openBrace Term some(Type) closeBrace { tyInst $1 $2 (NE.reverse $3) }
| openParen lam Name Type Term closeParen { LamAbs $2 $3 $4 $5 }
| openBracket Term some(Term) closeBracket { app $1 $2 (NE.reverse $3) } -- TODO should we reverse here or somewhere else?
| openParen con Constant closeParen { Constant $2 $3 }
| openParen iwrap Type Type Term closeParen { IWrap $2 $3 $4 $5 }
| openParen builtin builtinVar closeParen { Builtin $2 (BuiltinName (tkLoc $3) (tkBuiltin $3)) }
| openParen unwrap Term closeParen { Unwrap $2 $3 }
| openParen errorTerm Type closeParen { Error $2 $3 }
BuiltinType : integer { TyBuiltin $1 TyInteger }
| bytestring { TyBuiltin $1 TyByteString }
Type : TyName { TyVar (nameAttribute (unTyName $1)) $1 }
| openParen fun Type Type closeParen { TyFun $2 $3 $4 }
| openParen all TyName Kind Type closeParen { TyForall $2 $3 $4 $5 }
| openParen lam TyName Kind Type closeParen { TyLam $2 $3 $4 $5 }
| openParen ifix Type Type closeParen { TyIFix $2 $3 $4 }
| openBracket Type some(Type) closeBracket { tyApps $1 $2 (NE.reverse $3) }
| openParen con BuiltinType closeParen { $3 }
Kind : parens(type) { Type $1 }
| openParen fun Kind Kind closeParen { KindArrow $2 $3 $4 }
{
tyInst :: a -> Term tyname name a -> NonEmpty (Type tyname a) -> Term tyname name a
tyInst loc t (ty :| []) = TyInst loc t ty
tyInst loc t (ty :| tys) = TyInst loc (tyInst loc t (ty:|init tys)) (last tys)
tyApps :: a -> Type tyname a -> NonEmpty (Type tyname a) -> Type tyname a
tyApps loc ty (ty' :| []) = TyApp loc ty ty'
tyApps loc ty (ty' :| tys) = TyApp loc (tyApps loc ty (ty':|init tys)) (last tys)
app :: a -> Term tyname name a -> NonEmpty (Term tyname name a) -> Term tyname name a
app loc t (t' :| []) = Apply loc t t'
app loc t (t' :| ts) = Apply loc (app loc t (t':|init ts)) (last ts)
handleInteger :: AlexPosn -> Integer -> Parse (Constant AlexPosn)
handleInteger x i = pure $ x <$ (makeBuiltinInt i)
parseST :: BSL.ByteString -> StateT IdentifierState (Except (ParseError AlexPosn)) (Program TyName Name AlexPosn)
parseST str = runAlexST' str (runExceptT parsePlutusCoreProgram) >>= liftEither
parseTermST :: BSL.ByteString -> StateT IdentifierState (Except (ParseError AlexPosn)) (Term TyName Name AlexPosn)
parseTermST str = runAlexST' str (runExceptT parsePlutusCoreTerm) >>= liftEither
parseTypeST :: BSL.ByteString -> StateT IdentifierState (Except (ParseError AlexPosn)) (Type TyName AlexPosn)
parseTypeST str = runAlexST' str (runExceptT parsePlutusCoreType) >>= liftEither
mapParseRun :: (AsParseError e a, MonadError e m, MonadQuote m) => StateT IdentifierState (Except (ParseError a)) b -> m b
-- we need to run the parser starting from our current next unique, then throw away the rest of the
-- parser state and get back the new next unique
mapParseRun run = do
nextU <- liftQuote freshUnique
(p, (_, u)) <- throwingEither _ParseError $ runExcept $ runStateT run (identifierStateFrom nextU)
liftQuote $ markNonFreshBelow u
pure p
-- | Parse a PLC program. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
parseProgram :: (AsParseError e AlexPosn, MonadError e m, MonadQuote m) => BSL.ByteString -> m (Program TyName Name AlexPosn)
parseProgram str = mapParseRun (parseST str)
-- | Parse a PLC term. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
parseTerm :: (AsParseError e AlexPosn, MonadError e m, MonadQuote m) => BSL.ByteString -> m (Term TyName Name AlexPosn)
parseTerm str = mapParseRun (parseTermST str)
-- | Parse a PLC type. The resulting program will have fresh names. The underlying monad must be capable
-- of handling any parse errors.
parseType :: (AsParseError e AlexPosn, MonadError e m, MonadQuote m) => BSL.ByteString -> m (Type TyName AlexPosn)
parseType str = mapParseRun (parseTypeST str)
-- | Parse a 'ByteString' containing a Plutus Core program, returning a 'ParseError' if syntactically invalid.
--
-- >>> :set -XOverloadedStrings
-- >>> parse "(program 0.1.0 [(con addInteger) x y])"
-- Right (Program (AlexPn 1 1 2) (Version (AlexPn 9 1 10) 0 1 0) (Apply (AlexPn 15 1 16) (Apply (AlexPn 15 1 16) (Constant (AlexPn 17 1 18) (BuiltinName (AlexPn 21 1 22) AddInteger)) (Var (AlexPn 33 1 34) (Name {nameAttribute = AlexPn 33 1 34, nameString = "x", nameUnique = Unique {unUnique = 0}}))) (Var (AlexPn 35 1 36) (Name {nameAttribute = AlexPn 35 1 36, nameString = "y", nameUnique = Unique {unUnique = 1}}))))
parse :: BSL.ByteString -> Either (ParseError AlexPosn) (Program TyName Name AlexPosn)
parse str = fmap fst $ runExcept $ runStateT (parseST str) emptyIdentifierState
parseTm :: BSL.ByteString -> Either (ParseError AlexPosn) (Term TyName Name AlexPosn)
parseTm str = fmap fst $ runExcept $ runStateT (parseTermST str) emptyIdentifierState
parseTy :: BSL.ByteString -> Either (ParseError AlexPosn) (Type TyName AlexPosn)
parseTy str = fmap fst $ runExcept $ runStateT (parseTypeST str) emptyIdentifierState
type Parse = ExceptT (ParseError AlexPosn) Alex
parseError :: Token AlexPosn -> Parse b
parseError = throwError . Unexpected
}