purescript-lua · Unisay · Jul 8, 2026 · Jul 8, 2026 · Jul 8, 2026 · Jul 8, 2026
diff --git a/.hlint.yaml b/.hlint.yaml
@@ -94,6 +94,10 @@
 # - ignore: {name: Use let}
 # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
 
+# Keep `\_whatIsBeingDiscarded → …` over `const …`: the named-but-ignored
+# binder documents *what* is being discarded, which `const` erases.
+- ignore: {name: Use const}
+
 # Define some custom infix operators
 # - fixity: infixr 3 ~^#^~
 

diff --git a/changelog.d/20260708_090000_unisay_case_of_known_constructor.md b/changelog.d/20260708_090000_unisay_case_of_known_constructor.md
@@ -0,0 +1,16 @@
+### Added
+
+- Case-of-known-constructor folds in the IR optimizer (#177): a tag read over a
+  saturated sum-type constructor application (`ReflectCtor (K a₁ … aₙ)`) folds
+  to `K`'s tag string, and a field read (`DataArgumentByIndex i (K a₁ … aₙ)`)
+  folds to `aᵢ` — the algebraic-type twin of the existing record-projection
+  fold (`reduceObjectProp`). The tag fold then meets constant folding and the
+  unreachable-branch rules, collapsing a decision tree over a known
+  constructor to its live branch. Discarded arguments are dropped with the same
+  discipline DCE applies to unused bindings (an unrun `Effect` thunk is never a
+  casualty — an effect that must run is the kept field, not a dropped one). The
+  fold fires only at exact saturation, so a partial application is left a
+  function, and only sum types get the tag fold, since product constructors
+  carry no tag row. Standalone impact is near zero — the shapes appear once
+  dictionary specialization (#178/#180) inlines a constructor into a match — so
+  this lands as the enabler those issues build on.
diff --git a/lib/Language/PureScript/Backend/IR.hs b/lib/Language/PureScript/Backend/IR.hs
@@ -191,6 +191,7 @@ collectDataDeclarations cfnModules =
   -- A type is a product type iff it has exactly one constructor. Grouping the
   -- constructors by type first makes this independent of the order in which
   -- they appear in the module bindings.
+  classify ∷ Map k a → (AlgebraicType, Map k a)
   classify ctors =
     (if Map.size ctors == 1 then ProductType else SumType, ctors)
 

diff --git a/lib/Language/PureScript/Backend/IR/DCE.hs b/lib/Language/PureScript/Backend/IR/DCE.hs
@@ -327,6 +327,10 @@ eliminateDeadCode uber@UberModule {..} =
          where
           (scopeWithParams, paramNodes) =
             foldl' bindParam (scope, DL.empty) (toList params)
+          bindParam
+            ∷ (Scope, DList Node)
+            → Parameter (Id, b)
+            → (Scope, DList Node)
           bindParam (sc, nodes) = \case
             ParamUnused _ann' → (sc, nodes)
             ParamNamed (paramId, _ann') name →

diff --git a/lib/Language/PureScript/Backend/IR/Linker.hs b/lib/Language/PureScript/Backend/IR/Linker.hs
@@ -132,6 +132,7 @@ qualifyTopRefs moduleName = go
        where
         topNames' ∷ Set Name =
           foldl' shadowParam topNames parameters
+        shadowParam ∷ Set Name → Parameter ann → Set Name
         shadowParam names = \case
           ParamNamed _ann argName → Set.delete argName names
           ParamUnused _ann → names

diff --git a/lib/Language/PureScript/Backend/IR/MagicDo.hs b/lib/Language/PureScript/Backend/IR/MagicDo.hs
@@ -70,6 +70,7 @@ import Language.PureScript.Backend.IR.Types
   , noAnn
   , rewriteExpTopDownM
   , substituteMoveM
+  , unwindApp
   , pattern Abs
   , pattern App
   )
@@ -185,7 +186,7 @@ aliases, projecting fields out of literal dictionaries, and beta-reducing — an
 match once it is exposed as @bind dict action continuation@.
 -}
 classify ∷ (QName → Maybe Exp) → Exp → SupplyM (Maybe Node)
-classify resolve = go maxHops . spine
+classify resolve = go maxHops . unwindApp
  where
   go ∷ Int → (Exp, [Exp]) → SupplyM (Maybe Node)
   go fuel (hd, args)
@@ -228,7 +229,7 @@ classify resolve = go maxHops . spine
 
   -- Re-attach trailing arguments after a head reduction.
   reSpine ∷ Exp → [Exp] → (Exp, [Exp])
-  reSpine hd' extra = let (h, a) = spine hd' in (h, a <> extra)
+  reSpine hd' extra = let (h, a) = unwindApp hd' in (h, a <> extra)
 
 {- | Does the expression ultimately denote the given instance, possibly through
 module-local aliases?
@@ -250,14 +251,6 @@ isBindDict resolve dict =
 --------------------------------------------------------------------------------
 -- Helpers ---------------------------------------------------------------------
 
--- | Unwind an application into its head and arguments (left to right).
-spine ∷ Exp → (Exp, [Exp])
-spine = go []
- where
-  go ∷ [Exp] → Exp → (Exp, [Exp])
-  go acc (App _ f a) = go (a : acc) f
-  go acc h = (h, acc)
-
 {- | Run an Effect/ST computation: apply the thunk to no arguments. The
 synthetic @Prim.undefined@ argument is erased to an empty argument list by
 the Lua code generator, so this emits @m()@.

diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs
@@ -28,7 +28,8 @@ import Language.PureScript.Backend.IR.Pass
   )
 import Language.PureScript.Backend.IR.Supply (SupplyM, runSupply)
 import Language.PureScript.Backend.IR.Types
-  ( Ann
+  ( AlgebraicType (SumType)
+  , Ann
   , Exp
   , Grouping (..)
   , Parameter (..)
@@ -38,6 +39,7 @@ import Language.PureScript.Backend.IR.Types
   , alphaEq
   , countFreeRef
   , countFreeRefs
+  , ctorId
   , getAnn
   , isForeignImport
   , isNonRecursiveLiteral
@@ -49,8 +51,7 @@ import Language.PureScript.Backend.IR.Types
   , substituteCopyM
   , substituteMoveM
   , thenRewrite
-  , pattern Abs
-  , pattern App
+  , unwindApp
   )
 import Language.PureScript.Backend.IR.Uncurry (uncurryWorkerWrapper)
 import Language.PureScript.Backend.IR.Uniquify (uniquifyNames)
@@ -373,6 +374,7 @@ optimizedExpressionM =
   rewriteExpBottomUpM
     ( constantFolding
         `thenRewrite` reduceObjectProp
+        `thenRewrite` reduceKnownConstructor
         `thenRewrite` betaReduce
         `thenRewrite` removeUnreachableThenBranch
         `thenRewrite` removeUnreachableElseBranch
@@ -439,6 +441,52 @@ reduceObjectProp =
         Nothing → ObjectProp ann obj prop
     _ → Nothing
 
+{- | Case-of-known-constructor for algebraic types (issue #177), the
+'reduceObjectProp' twin for data constructors:
+
+  * @ReflectCtor (K a₁ … aₙ)@ — a tag read over a saturated /sum-type/
+    constructor application — folds to @K@'s tag string. The surrounding
+    equality test then meets 'constantFolding' and
+    'removeUnreachableThenBranch' / 'removeUnreachableElseBranch', which
+    collapse the decision tree to its live branch.
+  * @DataArgumentByIndex i (K a₁ … aₙ)@ — a field read — folds to @aᵢ@.
+
+A constructor application is the curried unary-'App' spine
+@App (… (App (Ctor …) a₁) …) aₙ@ that translation and the pattern
+matcher build. The fold fires only when the spine is /saturated/ (as
+many arguments as the constructor declares fields), so a partial
+application — still a function — is left alone.
+
+'ReflectCtor' folds for 'SumType' only: product constructors omit the
+@$ctor@ tag row in the generated Lua (see the @Ctor@ case of
+'Language.PureScript.Backend.Lua.fromIR'), so reducing a product-type
+tag read to a string would invent a value the runtime reads as @nil@.
+Field reads fold for either shape, since @valueᵢ@ rows exist for both.
+
+Discarded arguments are dropped, not evaluated — the discipline
+'reduceObjectProp' applies to discarded record fields and DCE applies to
+unused bindings. A dropped argument cannot skip an 'Effect': effects are
+unrun thunks here, run only when applied, so an effect that must run is
+the /kept/ argument (the field a match actually binds), never a dropped
+one; the only casualties are the pure divergence or partiality that DCE
+already elides. The folded value takes the read node's own annotation,
+not the argument's, for the reason spelled out on 'reduceObjectProp'.
+-}
+reduceKnownConstructor ∷ Applicative m ⇒ RewriteRuleM m Ann
+reduceKnownConstructor =
+  pure . \case
+    ReflectCtor ann scrutinee
+      | (Ctor _ SumType modName tyName ctorName fields, args) ←
+          unwindApp scrutinee
+      , length args == length fields →
+          Just $ LiteralString ann (ctorId modName tyName ctorName)
+    DataArgumentByIndex ann index scrutinee
+      | (Ctor _ _ _ _ _ fields, args) ← unwindApp scrutinee
+      , length args == length fields
+      , Just arg ← viaNonEmpty head (List.genericDrop index args) →
+          Just (setAnn ann arg)
+    _ → Nothing
+
 {- Note [Beta reduction and local inlining share an inlining guard]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 'betaReduce' and 'inlineLocalBinding' decide whether to paste an expression

diff --git a/lib/Language/PureScript/Backend/IR/Types.hs b/lib/Language/PureScript/Backend/IR/Types.hs
@@ -137,6 +137,19 @@ later alternative. Every unary rule keeps using it unchanged.
 pattern App ∷ ann → RawExp ann → RawExp ann → RawExp ann
 pattern App ann f a = AppN ann f (a :| [])
 
+{- | Peel a curried unary-'App' spine into its head and its arguments,
+first-applied first: @App (App f a₁) a₂@ becomes @(f, [a₁, a₂])@. A
+genuinely n-ary 'AppN' node is not a spine link and stays in the head
+(see Note [n-ary application]).
+-}
+unwindApp ∷ ∀ ann. RawExp ann → (RawExp ann, [RawExp ann])
+unwindApp = go []
+ where
+  go ∷ [RawExp ann] → RawExp ann → (RawExp ann, [RawExp ann])
+  go acc = \case
+    App _ f a → go (a : acc) f
+    e → (e, acc)
+
 {- Note [n-ary abstraction]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The definition-side counterpart of Note [n-ary application].
@@ -611,6 +624,7 @@ countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty
     AbsN _ann params body →
       countFreeRefs' (foldl' bindParam bound params) body
      where
+      bindParam ∷ Set Name → Parameter ann → Set Name
       bindParam names = \case
         ParamNamed _paramAnn name → Set.insert name names
         ParamUnused _paramAnn → names
@@ -856,6 +870,10 @@ freshenBinders = go Map.empty
       (renames', params') ← mapAccumM freshenParam renames params
       AbsN ann params' <$> go renames' body
      where
+      freshenParam
+        ∷ Map Name Name
+        → Parameter ann
+        → SupplyM (Map Name Name, Parameter ann)
       freshenParam rs = \case
         p@(ParamUnused _paramAnn) → pure (rs, p)
         ParamNamed paramAnn name → do

diff --git a/lib/Language/PureScript/Backend/IR/Uncurry.hs b/lib/Language/PureScript/Backend/IR/Uncurry.hs
@@ -110,8 +110,8 @@ import Language.PureScript.Backend.IR.Types
   , rewrittenIf
   , setAnn
   , subexpressions
+  , unwindApp
   , pattern Abs
-  , pattern App
   )
 
 {- | Split every qualifying binding into worker and wrapper and rewrite
@@ -359,16 +359,12 @@ taken: 'AppN' argument lists are not spines (Note [n-ary application]).
 -}
 saturatedSite
   ∷ Map (Qualified Name) Int → Exp → Maybe (Qualified Name, [Exp])
-saturatedSite arities e = case unwind e [] of
+saturatedSite arities e = case unwindApp e of
   (Ref _ann q, args)
     | Just arity ← Map.lookup q arities
     , length args == arity →
         Just (q, args)
   _ → Nothing
- where
-  unwind ∷ Exp → [Exp] → (Exp, [Exp])
-  unwind (App _ann fn a) acc = unwind fn (a : acc)
-  unwind hd acc = (hd, acc)
 
 {- | Count the saturated sites of each candidate within one expression.
 Absent keys have no sites.

diff --git a/lib/Language/PureScript/Backend/Lua/Printer.hs b/lib/Language/PureScript/Backend/Lua/Printer.hs
@@ -47,6 +47,7 @@ printStatements statements =
     statements
     (fmap Just (drop 1 statements) <> [Nothing])
  where
+  separator ∷ Maybe (Annotated Comments StatementF) → ADoc
   separator = \case
     Just (Ann next) | startsWithOpenParen next → ";"
     _ → mempty

diff --git a/test/Language/PureScript/Backend/IR/FlattenDeepBinds/Spec.hs b/test/Language/PureScript/Backend/IR/FlattenDeepBinds/Spec.hs
@@ -30,7 +30,6 @@ import Language.PureScript.Backend.IR.Types
   , refImported
   , refLocal
   , subexpressions
-  , pattern App
   )
 import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
 import Test.Hspec.Hedgehog.Extended (prop)

diff --git a/test/Language/PureScript/Backend/IR/Gen.hs b/test/Language/PureScript/Backend/IR/Gen.hs
@@ -61,7 +61,31 @@ exp =
       , Gen.subtermM exp \e →
           (`IR.lets` e) <$> Gen.nonEmpty (Range.linear 1 5) binding
       )
+    , (3, genCtorApp)
+    , (2, IR.reflectCtor <$> genCtorApp)
+    ,
+      ( 2
+      , IR.dataArgumentByIndex
+          <$> Gen.integral (Range.linear 0 3)
+          <*> genCtorApp
+      )
     ]
+ where
+  -- A saturated constructor application: exactly one argument per field
+  -- (nullary ctor ⇒ a bare 'Ctor'). This is the shape the #177
+  -- case-of-known-constructor fold matches on, so the fold-firing input
+  -- reaches the 'exp'-based suites too.
+  genCtorApp = do
+    fields ← Gen.list (Range.linear 0 3) fieldName
+    ctorExp ←
+      IR.ctor
+        <$> Gen.enumBounded
+        <*> moduleName
+        <*> tyName
+        <*> ctorName
+        <*> pure fields
+    args ← forM fields \_field → exp
+    pure (foldl' IR.application ctorExp args)
 
 {- | A generation-time scope: the local names with an enclosing binder.
 Lets 'scopedExp' emit only references that resolve to a binder.
@@ -108,9 +132,33 @@ scopedExpIn scope =
             (Range.linear 1 4)
             ((,) <$> genPropName <*> scopedExpIn scope)
       )
+    , (3, genCtorApp)
+    , (2, IR.reflectCtor <$> genCtorApp)
+    ,
+      ( 2
+      , IR.dataArgumentByIndex
+          <$> Gen.integral (Range.linear 0 3)
+          <*> genCtorApp
+      )
     ]
  where
   scopedRef = IR.refLocal <$> Gen.element (Set.toList scope)
+  -- A saturated constructor application: exactly one argument per field
+  -- (nullary ctor ⇒ a bare 'Ctor'). A 'Ctor' node binds nothing and
+  -- references no 'Scope' entry, so every argument just reuses the
+  -- incoming scope — the same category as application / if / object.
+  -- This is the shape the #177 case-of-known-constructor fold matches on.
+  genCtorApp = do
+    fields ← Gen.list (Range.linear 0 3) fieldName
+    ctorExp ←
+      IR.ctor
+        <$> Gen.enumBounded
+        <*> moduleName
+        <*> tyName
+        <*> ctorName
+        <*> pure fields
+    args ← forM fields \_field → scopedExpIn scope
+    pure (foldl' IR.application ctorExp args)
   genAbs = do
     (param, body) ← genBinderBody
     pure (IR.abstraction param body)