Fix parsing of lists and pairs.

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

@@ -90,7 +90,7 @@ genConstant = Gen.choice
 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/Parser.hs

@@ -59,22 +59,25 @@ appTerms = choice
             tms <- appTerms
             pure $ tm : tms
 
+conParser :: SomeTypeIn DefaultUni -> Parser (Some (ValueOf DefaultUni))
+conParser (SomeTypeIn DefaultUniInteger)     = conInt
+conParser (SomeTypeIn DefaultUniByteString)  = conChar
+conParser (SomeTypeIn DefaultUniString)      = conText
+conParser (SomeTypeIn DefaultUniUnit)        = conUnit
+conParser (SomeTypeIn DefaultUniBool)        = conBool
+conParser (SomeTypeIn (DefaultUniList a))    = conList a
+conParser (SomeTypeIn (DefaultUniPair a b))  = conPair
+conParser (SomeTypeIn DefaultUniProtoList )  = conEmpty
+conParser (SomeTypeIn DefaultUniProtoPair )  = conEmpty
+conParser (SomeTypeIn (DefaultUniApply _ _)) = conEmpty
+conParser (SomeTypeIn DefaultUniData)        = conEmpty
+
 -- | 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 <-
-        case conTy of
-            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
+    conTy <- defaultUniType
+    con <- conParser conTy
     pure $ Constant p con
 
 builtinTerm :: Parser PTerm

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

@@ -135,9 +135,8 @@ defaultUniType = choice $ map try
   , SomeTypeIn DefaultUniString <$ symbol "string"
   , SomeTypeIn DefaultUniUnit <$ symbol "unit"
   , SomeTypeIn DefaultUniBool <$ symbol "bool"
---   , SomeTypeIn DefaultUniProtoList <$ symbol "list"
+--   , SomeTypeIn DefaultUniList <$ symbol "list"
 --   , SomeTypeIn DefaultUniProtoPair <$ symbol "pair"
-  -- , SomeTypeIn DefaultUniApply <$ symbol "?" TODO need to make this an operator
     ]
 
 inParens :: Parser a -> Parser a
@@ -281,43 +280,55 @@ conBool = choice
     , someValue False <$ symbol "False"
     ]
 
-constants :: Parser [Some (ValueOf DefaultUni)]
-constants = choice
-    [ try cons
+constants :: SomeTypeIn DefaultUni -> Parser [Some (ValueOf DefaultUni)]
+constants ty = choice
+    [ try (cons ty)
     , do
         oneCon <- constant
         pure [oneCon]
     ]
-    where cons = do
-            con <- constant
+    where cons dType = do
+            con <- conParser dType
             _ <- symbol ","
-            maybeCons <- constants
+            maybeCons <- constants dType
             pure $ con : maybeCons
 
-conList :: Parser (Some (ValueOf DefaultUni))
-conList = inBraces $ do
+mkList :: SomeTypeIn DefaultUni -> Some (ValueOf DefaultUni) -> Maybe [Some (ValueOf DefaultUni)] -> Some (ValueOf DefaultUni)
+mkList (SomeTypeIn ty) hd Nothing =
+    case hd of
+        (Some (ValueOf ty x)) -> Some $ ValueOf (DefaultUniList ty) [x]
+        _                     -> error $ "mkList: item" <> show x <> "in the list has the wrong type."
+mkList (SomeTypeIn ty) hd (Just tail) =
+    case (hd, tail) of
+        (Some (ValueOf ty x), [Some (ValueOf ty y)]) ->
+            Some $ ValueOf (DefaultUniList ty) [x,y]
+        (Some (ValueOf ty x), hd:xs) ->
+            Some $ ValueOf (DefaultUniList ty) $ x:mkList hd xs
+        (_, _) -> error "mkList: type error, items in the lists are not of the right types."
+
+-- conList :: PType -> Parser (Some (ValueOf DefaultUni))
+conList ty = inBraces $ do
     conFirst <- constant
-    list <- constants
-    pure $ someValue [conFirst] -- :list
+    list <- constants ty
+    pure $ ValueOf ty conFirst
+
+mkPair :: Some (ValueOf DefaultUni) -> Some (ValueOf DefaultUni) -> Some (ValueOf DefaultUni)
+mkPair (Some (ValueOf uniA x)) (Some (ValueOf uniB y)) = Some $ ValueOf (DefaultUniPair uniA uniB) (x, y)
 
 conPair :: Parser (Some (ValueOf DefaultUni))
 conPair = inBrackets $ do
     conFirst <- constant
-    pairList <- constants
-    pure $ pairConst conFirst pairList
+    pairConst conFirst <$> constants
 
-pairConst ::
-    Some (ValueOf DefaultUni) ->
+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"
+pairConst t [t']      = mkPair t t'
+pairConst t (t' : ts) = mkPair (pairConst t (t':init ts)) (last ts)
 
-conData :: Parser (Some (ValueOf DefaultUni)) --FIXME
-conData = pure $ someValue $ T.pack "data"
+-- | Empty parser to complete case matching of conParser.
+conEmpty :: Parser (Some (ValueOf DefaultUni)) --FIXME
+conEmpty = pure $ someValue $ T.pack "conEmpty: Not Implemented."
 
 constant :: Parser (Some (ValueOf DefaultUni))
 constant = choice $ map try

plutus-core/plutus-core/src/Universe/Core.hs

@@ -441,7 +441,7 @@ runDecodeUniM is (DecodeUniM a) = runStateT a is
 -- @UList (UList UInt)@ can be encoded to @[0,0,1]@ where @0@ and @1@ are the integer tags of the
 -- @UList@ and @UInt@ constructors, respectively.
 class Closed uni where
-    -- | A constrant for \"@constr a@ holds for any @a@ from @uni@\".
+    -- | A constraint for \"@constr a@ holds for any @a@ from @uni@\".
     type Everywhere uni (constr :: Type -> Constraint) :: Constraint
 
     -- | Encode a type as a sequence of 'Int' tags.