WIP fix parsing of list and pair.

plutus-core/generators/PlutusCore/Generators/AST.hs

@@ -86,11 +86,11 @@ genConstant = Gen.choice
     , someValue <$> Gen.utf8 (Range.linear 0 40) Gen.unicode
     ]
 
--- We only generate types that are parsable. See Note [Parsing horribly broken].
+-- We only generate types that are parsable.
 genSomeTypeIn :: AstGen (SomeTypeIn DefaultUni)
 genSomeTypeIn = Gen.frequency
     [ (1, pure $ SomeTypeIn DefaultUniInteger)
-    , (1, pure $ SomeTypeIn DefaultUniByteString)
+    -- , (1, pure $ SomeTypeIn DefaultUniByteString)
     , (1, pure $ SomeTypeIn DefaultUniString)
     , (1, pure $ SomeTypeIn DefaultUniUnit)
     , (1, pure $ SomeTypeIn DefaultUniBool)

plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs

@@ -135,35 +135,6 @@ instance Show (DefaultUni a) where
         uniG `DefaultUniApply` _ `DefaultUniApply` _ -> noMoreTypeFunctions uniG
     show DefaultUniData = "data"
 
--- -- See Note [Parsing horribly broken].
--- instance Parsable (SomeTypeIn (Kinded DefaultUni)) where
---     parse "bool"       = Just . SomeTypeIn $ Kinded DefaultUniBool
---     parse "bytestring" = Just . SomeTypeIn $ Kinded DefaultUniByteString
---     parse "string"     = Just . SomeTypeIn $ Kinded DefaultUniString
---     parse "integer"    = Just . SomeTypeIn $ Kinded DefaultUniInteger
---     parse "unit"       = Just . SomeTypeIn $ Kinded DefaultUniUnit
---     parse text         = asum
---         [ do
---             aT <- Text.stripPrefix "[" text >>= Text.stripSuffix "]"
---             SomeTypeIn (Kinded a) <- parse aT
---             Refl <- checkStar @DefaultUni a
---             Just . SomeTypeIn . Kinded $ DefaultUniList a
---         , do
---             abT <- Text.stripPrefix "(" text >>= Text.stripSuffix ")"
---             -- Note that we don't allow whitespace after @,@ (but we could).
---             -- Anyway, looking for a single comma is just plain wrong, as we may have a nested
---             -- tuple (and it can be left- or right- or both-nested), so we're running into
---             -- the same parsing problem as with constants.
---             case Text.splitOn "," abT of
---                 [aT, bT] -> do
---                     SomeTypeIn (Kinded a) <- parse aT
---                     Refl <- checkStar @DefaultUni a
---                     SomeTypeIn (Kinded b) <- parse bT
---                     Refl <- checkStar @DefaultUni b
---                     Just . SomeTypeIn . Kinded $ DefaultUniPair a b
---                 _ -> Nothing
---         ]
-
 instance DefaultUni `Contains` Integer       where knownUni = DefaultUniInteger
 instance DefaultUni `Contains` BS.ByteString where knownUni = DefaultUniByteString
 instance DefaultUni `Contains` Text.Text     where knownUni = DefaultUniString

plutus-core/plutus-core/src/PlutusCore/Parser.hs

@@ -66,11 +66,15 @@ conTerm = inParens $ do
     conTy <- defaultUniType -- TODO: do case of for each ty?
     con <-
         case conTy of
-            SomeTypeIn DefaultUniInteger    -> conInt
-            SomeTypeIn DefaultUniByteString -> conChar
-            SomeTypeIn DefaultUniString     -> conText
-            SomeTypeIn DefaultUniUnit       -> conUnit
-            SomeTypeIn DefaultUniBool       -> conBool
+            SomeTypeIn DefaultUniInteger     -> conInt
+            SomeTypeIn DefaultUniByteString  -> conChar
+            SomeTypeIn DefaultUniString      -> conText
+            SomeTypeIn DefaultUniUnit        -> conUnit
+            SomeTypeIn DefaultUniBool        -> conBool
+            SomeTypeIn DefaultUniProtoList   -> conList
+            SomeTypeIn DefaultUniProtoPair   -> conPair
+            SomeTypeIn (DefaultUniApply _ _)-> conApp
+            SomeTypeIn DefaultUniData        -> conData
     pure $ Constant p con
 
 builtinTerm :: Parser PTerm

plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs

@@ -259,10 +259,12 @@ conInt = do
 -- | Parser for bytestring constants. They start with "#".
 conChar :: Parser (Some (ValueOf DefaultUni))
 conChar = do
-    con <- char '#' *> Text.Megaparsec.many hexDigitChar--Lex.charLiteral
+    con <- char '#' *> Text.Megaparsec.many hexDigitChar
     pure $ someValue $ T.pack con
 
 -- | Parser for string constants. They are wrapped in double quotes.
+-- Even though @takeWhile@ is more efficient, @manyTill@ is easier to use
+-- here and we don't care much about efficiency.
 conText :: Parser (Some (ValueOf DefaultUni))
 conText = do
     con <- char '\"' *> manyTill Lex.charLiteral (char '\"')
@@ -279,13 +281,43 @@ conBool = choice
     , someValue False <$ symbol "False"
     ]
 
---TODO fix these (add parsing of constant after symbol?):
--- conPair :: Parser (Some (ValueOf DefaultUni))
--- conPair = someValue (,) <$ symbol "pair"
--- conList :: Parser (Some (ValueOf DefaultUni))
--- conList = someValue [] <$ symbol "list"
--- conData :: Parser (Some (ValueOf DefaultUni))
--- conData = someValue Data? <$ symbol "data"
+constants :: Parser [Some (ValueOf DefaultUni)]
+constants = choice
+    [ try cons
+    , do
+        oneCon <- constant
+        pure [oneCon]
+    ]
+    where cons = do
+            con <- constant
+            _ <- symbol ","
+            maybeCons <- constants
+            pure $ con : maybeCons
+
+conList :: Parser (Some (ValueOf DefaultUni))
+conList = inBraces $ do
+    conFirst <- constant
+    list <- constants
+    pure $ someValue [conFirst] -- :list
+
+conPair :: Parser (Some (ValueOf DefaultUni))
+conPair = inBrackets $ do
+    conFirst <- constant
+    pairList <- constants
+    pure $ pairConst conFirst pairList
+
+pairConst ::
+    Some (ValueOf DefaultUni) ->
+    [Some (ValueOf DefaultUni)] -> Some (ValueOf DefaultUni)
+pairConst _t []       = error "pairConst: A pair without second."
+pairConst t [t']      = someValue (t, t')
+pairConst t (t' : ts) = someValue (someValue (t, t':init ts), last ts)
+
+conApp :: Parser (Some (ValueOf DefaultUni)) --FIXME
+conApp = pure $ someValue $ T.pack "app"
+
+conData :: Parser (Some (ValueOf DefaultUni)) --FIXME
+conData = pure $ someValue $ T.pack "data"
 
 constant :: Parser (Some (ValueOf DefaultUni))
 constant = choice $ map try