Generalized cond parsing

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

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

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