-
Notifications
You must be signed in to change notification settings - Fork 463
/
Builtin.hs
101 lines (85 loc) · 3.71 KB
/
Builtin.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
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module PlutusCore.Parser.Builtin where
import PlutusPrelude (Word8, reoption)
import PlutusCore.Default
import PlutusCore.Error (ParserError (UnknownBuiltinFunction))
import PlutusCore.Parser.ParserCommon
import PlutusCore.Parser.Type (defaultUni)
import PlutusCore.Pretty (display)
import Control.Monad.Combinators
import Data.ByteString (ByteString, pack)
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.Internal.Read (hexDigitToInt)
import Text.Megaparsec (customFailure, getSourcePos, takeWhileP)
import Text.Megaparsec.Char (char, hexDigitChar)
import Text.Megaparsec.Char.Lexer qualified as Lex
cachedBuiltin :: Map.Map T.Text DefaultFun
cachedBuiltin = Map.fromList [ (display fn, fn) | fn <- [minBound .. maxBound] ]
-- | Parser for builtin functions. Atm the parser can only parse `DefaultFun`.
builtinFunction :: Parser DefaultFun
builtinFunction = lexeme $ do
txt <- takeWhileP (Just "builtin function identifier") isIdentifierChar
case Map.lookup txt cachedBuiltin of
Nothing -> do
let lBuiltin = fmap fst $ Map.toList cachedBuiltin
pos <- getSourcePos
customFailure $ UnknownBuiltinFunction txt pos lBuiltin
Just builtin -> pure builtin
-- | Parser for integer constants.
conInteger :: Parser Integer
conInteger = Lex.signed whitespace (lexeme Lex.decimal)
-- | Parser for a pair of hex digits to a Word8.
hexByte :: Parser Word8
hexByte = do
high <- hexDigitChar
low <- hexDigitChar
pure $ fromIntegral (hexDigitToInt high * 16 + hexDigitToInt low)
-- | Parser for bytestring constants. They start with "#".
conBS :: Parser ByteString
conBS = lexeme . fmap pack $ char '#' *> many hexByte
-- | Parser for string constants. They are wrapped in double quotes.
conText :: Parser T.Text
conText = lexeme . fmap T.pack $ char '\"' *> manyTill Lex.charLiteral (char '\"')
-- | Parser for unit.
conUnit :: Parser ()
conUnit = () <$ (symbol "(" *> symbol ")")
-- | Parser for bool.
conBool :: Parser Bool
conBool = choice
[ True <$ symbol "True"
, False <$ symbol "False"
]
-- | Parser for lists.
conList :: DefaultUni (Esc a) -> Parser [a]
conList uniA = inBrackets $ constantOf uniA `sepBy` symbol ","
-- | Parser for pairs.
conPair :: DefaultUni (Esc a) -> DefaultUni (Esc b) -> Parser (a, b)
conPair uniA uniB = inParens $ do
a <- constantOf uniA
_ <- symbol ","
b <- constantOf uniB
pure (a, b)
-- | Parser for constants of the given type.
constantOf :: DefaultUni (Esc a) -> Parser a
constantOf uni = case uni of
DefaultUniInteger -> conInteger
DefaultUniByteString -> conBS
DefaultUniString -> conText
DefaultUniUnit -> conUnit
DefaultUniBool -> conBool
DefaultUniProtoList `DefaultUniApply` uniA -> conList uniA
DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB -> conPair uniA uniB
f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _ -> noMoreTypeFunctions f
DefaultUniData ->
fail "Data not supported"
-- | Parser of constants whose type is in 'DefaultUni'.
constant :: Parser (Some (ValueOf DefaultUni))
constant = do
-- Parse the type tag.
SomeTypeIn (Kinded uni) <- defaultUni
-- Check it's of kind @*@.
Refl <- reoption $ checkStar uni
-- Parse the constant of the type represented by the type tag.
someValueOf uni <$> constantOf uni