Fix pattern matching

flake.nix

@@ -69,7 +69,7 @@
             src = gitignore ./.;
           } ''
             cd $src
-            ormolu --mode check $(find . -name '*.hs')
+            ormolu --mode check $(find app src yule test -name '*.hs')
             touch $out
           '';
 

src/Solcore/Backend/Specialise.hs

@@ -405,7 +405,17 @@ specFunDef fd0 = withLocalState do
       return name'
 
 specBody :: [Stmt Id] -> SM [Stmt Id]
-specBody = mapM specStmt
+specBody = fmap concat . mapM specStmtBody
+  where
+    specStmtBody stmt = do
+      stmt' <- specStmt stmt
+      pure (flattenSyntheticBlock stmt')
+
+    -- The match compiler uses `Match [] [([], body)]` as an internal block
+    -- wrapper for multi-statement leaves. Flatten it before converting to MAST,
+    -- where zero-scrutinee matches are not representable.
+    flattenSyntheticBlock (Match [] [([], body)]) = body
+    flattenSyntheticBlock stmt = [stmt]
 
 {-
 ensureSimple ty' stmt subst = case ty' of

src/Solcore/Desugarer/DecisionTreeCompiler.hs

@@ -102,17 +102,30 @@ instance Compile (Stmt Id) where
     es' <- compile es
     eqns' <- mapM compileEqn eqns
     scrutTys <- mapM scrutineeType es'
-    let occs = [[i] | i <- [0 .. length es' - 1]]
-        occMap = Map.fromList (zip occs es')
+    preparedScruts <- zipWithM prepareScrutinee es' scrutTys
+    let scrutBindings = concatMap fst preparedScruts
+        scrutVars = map snd preparedScruts
+        occs = [[i] | i <- [0 .. length es' - 1]]
+        occMap = Map.fromList (zip occs scrutVars)
         matrix = map fst eqns'
         actions = map snd eqns'
         bacts = [([], a) | a <- actions]
-        matchDesc = "match (" ++ intercalate ", " (map pretty es') ++ ")"
+        matchDesc = "match (" ++ intercalate ", " (map pretty scrutVars) ++ ")"
     pushCtx matchDesc $ do
       ctx <- askWarnCtx
       checkRedundancy ctx scrutTys matrix bacts
     tree <- pushCtx matchDesc $ compileMatrix scrutTys occs matrix bacts
-    treeToStmt occMap tree
+    stmt <- treeToStmt occMap tree
+    pure $
+      case scrutBindings of
+        [] -> stmt
+        binds -> Match [] [([], binds ++ [stmt])]
+
+prepareScrutinee :: Exp Id -> Ty -> CompilerM ([Stmt Id], Exp Id)
+prepareScrutinee e@(Var _) _ = pure ([], e)
+prepareScrutinee e ty = do
+  v <- freshId ty
+  pure ([Let v (Just ty) (Just e)], Var v)
 
 compileEqn :: Equation Id -> CompilerM (Equation Id)
 compileEqn (pats, stmts) = (pats,) <$> compile stmts
@@ -415,6 +428,13 @@ freshPat t = do
   let v = Name $ "$v" ++ show n
   pure (PVar (Id v t))
 
+freshId :: Ty -> CompilerM Id
+freshId t = do
+  pat <- freshPat t
+  case pat of
+    PVar v -> pure v
+    _ -> error "freshId: freshPat returned a non-variable pattern"
+
 isComplete :: [Id] -> CompilerM Bool
 isComplete [] = pure False
 isComplete ks@(first : _) = do

test/Cases.hs

@@ -311,7 +311,8 @@ cases =
       runTestExpectingFailure "overlap-synonym-missed-order.solc" caseFolder,
       runTestExpectingFailure "overlap-synonym-missed-two-synonyms.solc" caseFolder,
       runTestForFile "copytomem.solc" caseFolder,
-      runTestForFile "fresh-variable-shadowing.solc" caseFolder
+      runTestForFile "fresh-variable-shadowing.solc" caseFolder,
+      runTestForFile "multi-stmt-var-leaf.solc" caseFolder
     ]
   where
     caseFolder = "./test/examples/cases"

test/MatchCompilerTests.hs

@@ -1,5 +1,6 @@
 module MatchCompilerTests where
 
+import Data.Generics (everything, mkQ)
 import Data.List (sort)
 import Data.Map qualified as Map
 import Solcore.Desugarer.DecisionTreeCompiler
@@ -30,7 +31,8 @@ matchTests =
       testGroup
         "treeToStmt"
         [ test_treeToStmt_singleVar_substituted,
-          test_treeToStmt_multiColumn_varsBoundViaSpecialize
+          test_treeToStmt_multiColumn_varsBoundViaSpecialize,
+          test_compileMatch_bindsScrutineeOnce
         ],
       testGroup
         "redundancy warnings"
@@ -101,6 +103,13 @@ runFull env occMap tys occs matrix acts =
     tree <- compileMatrix tys occs matrix [([], a) | a <- acts]
     treeToStmt occMap tree
 
+runCompileStmt ::
+  TypeEnv ->
+  Stmt Id ->
+  IO (Either String (Stmt Id, [Warning]))
+runCompileStmt env stmt =
+  runCompilerM env (compile stmt)
+
 assertRight ::
   String ->
   IO (Either String (DecisionTree, [Warning])) ->
@@ -466,6 +475,12 @@ varX = Var (Id (Name "x") tyBool)
 varY :: Exp Id
 varY = Var (Id (Name "y") tyBool)
 
+idF :: Id
+idF = Id (Name "f") (funtype [] tyBool)
+
+idG :: Id
+idG = Id (Name "g") (funtype [tyBool, tyBool] tyBool)
+
 -- Type environment with both List and Bool constructors
 listBoolEnv :: TypeEnv
 listBoolEnv = Map.union listEnv boolEnv
@@ -514,7 +529,38 @@ test_treeToStmt_multiColumn_varsBoundViaSpecialize =
             [] -> assertFailure "default branch not found in Match alts"
         _ -> assertFailure ("expected Match [x] …, got: " ++ show stmt)
 
--- 13. Rows after a first all-var row are warned as unreachable even when they
+-- 13. Compiling a catch-all over a non-variable scrutinee must not duplicate
+-- scrutinee evaluation.
+--
+-- match f() { | z => return g(z, z) }
+--
+-- The compiled statement should evaluate f() once and reuse the bound result.
+test_compileMatch_bindsScrutineeOnce :: TestTree
+test_compileMatch_bindsScrutineeOnce =
+  testCase "compile Match: catch-all row evaluates scrutinee only once" $ do
+    let idZ = Id (Name "z") tyBool
+        stmt =
+          Match
+            [Call Nothing idF []]
+            [([PVar idZ], [Return (Call Nothing idG [Var idZ, Var idZ])])]
+    r <- runCompileStmt boolEnv stmt
+    case r of
+      Left err -> assertFailure ("unexpected error: " ++ err)
+      Right (stmt', _) ->
+        assertEqual
+          "f() should appear exactly once after compilation"
+          1
+          (countNamedCalls (idName idF) stmt')
+  where
+    countNamedCalls :: Name -> Stmt Id -> Int
+    countNamedCalls target =
+      everything (+) (mkQ 0 countExp)
+      where
+        countExp :: Exp Id -> Int
+        countExp (Call Nothing i _) | idName i == target = 1
+        countExp _ = 0
+
+-- 14. Rows after a first all-var row are warned as unreachable even when they
 -- are NOT exhaustive by themselves.
 --
 -- match x { | z => return z; | True => return True; }
@@ -541,7 +587,7 @@ test_allVar_first_shadows_nonexhaustive_rest =
       assertBool "True clause must be warned as unreachable" (actionB `elem` redundantActs)
       assertBool "first all-var row must not be warned" (actionA `notElem` redundantActs)
 
--- 14. Two-column match: (True,z) / (w,True) / (a,b)
+-- 15. Two-column match: (True,z) / (w,True) / (a,b)
 -- The rows after the first are NOT globally redundant:
 --   row 1 fires for (False, True), row 2 fires for (False, False).
 -- No RedundantClause warnings should be emitted.

test/examples/cases/multi-stmt-var-leaf.solc

@@ -0,0 +1,11 @@
+data Bool = False | True;
+
+contract MultiStmtVarLeaf {
+  function main(x:Bool) -> Bool {
+    match x {
+      | y =>
+        let z = y;
+        return z;
+    }
+  }
+}