From 477b3900c78e855d9b4ad1104f9ed3bc05513809 Mon Sep 17 00:00:00 2001
From: 0xd34df00d <0xd34df00d@gmail.com>
Date: Thu, 7 Sep 2023 21:25:55 -0500
Subject: [PATCH] Generalized cond parsing

---
 src/Pact/Compile.hs         | 18 +++++++++++++++---
 src/Pact/Interpreter.hs     |  6 ++++--
 src/Pact/Types/ExpParser.hs | 11 +++++++----
 3 files changed, 26 insertions(+), 9 deletions(-)

diff --git a/src/Pact/Compile.hs b/src/Pact/Compile.hs
index 5cc6ceb8f..f4140452a 100644
--- a/src/Pact/Compile.hs
+++ b/src/Pact/Compile.hs
@@ -35,6 +35,7 @@ import Control.Arrow ((&&&),first)
 import Control.Exception hiding (try)
 import Control.Lens hiding (prism)
 import Control.Monad
+import Control.Monad.Reader (asks)
 import Control.Monad.State
 
 import qualified Data.ByteString as BS
@@ -613,13 +614,24 @@ abstractBody' args body =
 
 condForm :: Compile (Term Name)
 condForm = do
-  conds <- conds'
-  elseCond <- valueLevel
+  generalized <- asks _peCondGenParsing
+  (conds, elseCond) <-
+    if generalized
+       then partitionCond =<< some (Right <$> valueLevel `notFollowedBy'` cond' <|> Left <$> cond')
+       else (,) <$> some cond' <*> valueLevel
   i <- contextInfo
   let if' = TVar (Name (BareName "if" i)) i
   pure $ foldr (\(cond, act) e -> TApp (App if' [cond, act, e] i) i) elseCond conds
   where
-  conds' = some $ withList' Parens $ (,) <$> valueLevel <*> valueLevel
+  cond' = withList' Parens $ (,) <$> valueLevel <*> valueLevel
+
+  partitionCond [Right elseCond] = pure ([], elseCond)
+  partitionCond (Left cond : rest@(_:_)) = first (cond :) <$> partitionCond rest
+  partitionCond [Left _] = error "condForm: impossible: Left _ cannot be the last element"
+  partitionCond (Right _ : _ : _) = expected "a single fallback clause"
+  partitionCond [] = expected "condition clauses"
+
+  p `notFollowedBy'` q = try $ p <* notFollowedBy q
 
 letForm :: Compile (Term Name)
 letForm = do
diff --git a/src/Pact/Interpreter.hs b/src/Pact/Interpreter.hs
index cfa161fc9..2a739c96d 100644
--- a/src/Pact/Interpreter.hs
+++ b/src/Pact/Interpreter.hs
@@ -148,10 +148,12 @@ data EvalResult = EvalResult
 -- | Execute pact statements.
 evalExec :: Interpreter e -> EvalEnv e -> ParsedCode -> IO EvalResult
 evalExec runner evalEnv ParsedCode {..} = do
-  terms <- throwEither $ compileExps (ParseEnv isNarrowTry) (mkTextInfo _pcCode) _pcExps
+  terms <- throwEither $ compileExps (ParseEnv isNarrowTry condGenParsing) (mkTextInfo _pcCode) _pcExps
   interpret runner evalEnv (Right terms)
   where
-    isNarrowTry = not $ S.member FlagDisablePact44 $ _ecFlags $ _eeExecutionConfig evalEnv
+    evalFlags = _ecFlags $ _eeExecutionConfig evalEnv
+    isNarrowTry = not $ S.member FlagDisablePact44 evalFlags
+    condGenParsing = not $ S.member FlagDisablePact49 evalFlags
 
 -- | For pre-installing modules into state.
 initStateModules :: HashMap ModuleName (ModuleData Ref) -> EvalState
diff --git a/src/Pact/Types/ExpParser.hs b/src/Pact/Types/ExpParser.hs
index cd2685c36..511810b2a 100644
--- a/src/Pact/Types/ExpParser.hs
+++ b/src/Pact/Types/ExpParser.hs
@@ -107,10 +107,13 @@ data ParseState a = ParseState
   }
 makeLenses ''ParseState
 
--- | Current env has flag for try-narrow fix.
-newtype ParseEnv = ParseEnv
-    { _peNarrowTry :: Bool }
-instance Default ParseEnv where def = ParseEnv True
+data ParseEnv = ParseEnv
+    { _peNarrowTry :: Bool
+    -- ^ Enable try-narrow fix.
+    , _peCondGenParsing :: Bool
+    -- ^ Enable more general `cond` parsing.
+    }
+instance Default ParseEnv where def = ParseEnv True True
 
 type MkInfo = Parsed -> Info