From 79a4498d5cfd5394f1a0ec463c504b27ce2427a9 Mon Sep 17 00:00:00 2001
From: Marty Stumpf <thealmartyblog@gmail.com>
Date: Tue, 14 Dec 2021 10:24:57 -0800
Subject: [PATCH] Add constant term parser.

---
 .../src/PlutusCore/Parser/ParserCommon.hs     | 62 ++++++++++++++-----
 .../src/UntypedPlutusCore/Parser.hs           |  8 ++-
 2 files changed, 52 insertions(+), 18 deletions(-)

diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs
index fe4f54bfa99..d4d55062220 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs
@@ -1,9 +1,8 @@
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE TypeOperators     #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
 
 -- | Common functions for parsers of UPLC, PLC, and PIR.
 
@@ -13,7 +12,6 @@ import Data.Char (isAlphaNum)
 import Data.Map qualified as M
 import Data.Text qualified as T
 import PlutusCore qualified as PLC
-import PlutusCore.Parsable qualified as PLC
 import PlutusPrelude
 import Text.Megaparsec hiding (ParseError, State, parse)
 import Text.Megaparsec.Char (char, letterChar, space1, string)
@@ -21,7 +19,7 @@ import Text.Megaparsec.Char.Lexer qualified as Lex
 
 import Control.Monad.State (MonadState (get, put), StateT, evalStateT)
 
-import Data.Proxy (Proxy (Proxy))
+import Universe.Core (someValue)
 
 newtype ParserState = ParserState { identifiers :: M.Map T.Text PLC.Unique }
     deriving (Show)
@@ -103,7 +101,7 @@ wordPos ::
     T.Text -> Parser SourcePos
 wordPos w = lexeme $ try $ getSourcePos <* symbol w
 
-builtinFunction :: (Bounded fun, Enum fun, Pretty fun) => Parser fun
+builtinFunction :: Parser PLC.DefaultFun
 builtinFunction = lexeme $ choice $ map parseBuiltin [minBound .. maxBound]
     where parseBuiltin builtin = try $ string (display builtin) >> pure builtin
 
@@ -133,16 +131,50 @@ enforce p = do
     pure x
 
 -- | Parser for integer constants.
-consInt :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
-consInt = lexeme Lex.decimal
+conInt :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
+conInt = lexeme Lex.decimal
+
+-- | Parser for single quoted char.
+conChar :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
+conChar = do
+    con <- between (char '\'') (char '\'') Lex.charLiteral
+    pure $ someValue con
+
+-- | Parser for double quoted string.
+conText :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
+conText = do
+    con <- char '\"' *> manyTill Lex.charLiteral (char '\"')
+    pure $ someValue $ pack con
+
+-- | Parser for unit.
+conUnit :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
+conUnit = someValue () <$ symbol "unit"
+
+-- | Parser for bool.
+conBool :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
+conBool = choose
+    [ someValue True <$ symbol "True"
+    , someValue False <$ symbol "False"
+    ]
+
+--TODO
+-- conPair :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
+-- conPair = someValue (,) <$ symbol "pair"
+
+-- conList :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
+-- conList = someValue [] <$ symbol "list"
 
--- TODO case of defaultuni type then use the type specific parser
 constant :: Parser (PLC.Some (PLC.ValueOf PLC.DefaultUni))
-constant = choice
+constant = choose
     [ inParens constant
-    , consInt
-    , between (char '\'') (char '\'') Lex.charLiteral -- single quoted char
-    , char '\"' *> takeWhileP Lex.charLiteral (char '\"') -- double quoted string
-    -- TODO add unit, list, pair
-    ]
-
+    , conInt
+    , conChar
+    , conText
+    , conUnit
+    , conBool]
+
+constantTerm :: Parser (PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
+constantTerm = do
+    p <- getSourcePos
+    con <- constant
+    pure $ Constant p con
diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs
index 08dbb7c0e76..1b6d9729aba 100644
--- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs
+++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs
@@ -45,8 +45,7 @@ import PlutusCore.Parser.ParserCommon
 conTerm :: Parser (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SourcePos)
 conTerm = inParens $ UPLC.Constant <$> wordPos "con" <*> constant
 
-builtinTerm :: (Bounded fun, Enum fun, Pretty fun)
-    => Parser (UPLC.Term PLC.Name uni fun SourcePos)
+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)
@@ -121,7 +120,10 @@ parseProgram = parseGen program
 
 -- | Parse and rewrite so that names are globally unique, not just unique within
 -- their scope.
-parseScoped :: ByteString
+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