`Alternative` 中的模式匹配

Question

我有一个函数在其参数上进行模式匹配以在StateT () Maybe () 中产生计算。此计算在运行时可能会失败，在这种情况下，我希望当前模式匹配分支失败。

我非常怀疑有可能有类似的东西

compute :: Int -> StateT () Maybe Int
compute = return

f :: Maybe Int -> Maybe Int -> StateT () Maybe ()
f (Just n1) (Just n2) = do
  m <- compute (n1 + n2) 
  guard (m == 42)
f (Just n) _ = do
  m <- compute n
  guard (m == 42)
f _ (Just n) = do
  m <- compute n
  guard (m == 42)

按照我希望的方式行事：当第一次计算由于guard 或compute 的某个位置而失败时，我希望f 尝试下一个模式。

显然上述方法行不通，因为StateT（就像任何其他 monad 一样）在扩展时涉及一个附加参数，所以我可能无法将其表述为简单的模式保护。

以下是我想要的，但它很丑：

f' :: Maybe Int -> Maybe Int -> StateT () Maybe ()
f' a b = asum (map (\f -> f a b) [f1, f2, f3])
  where
    f1 a b = do
      Just n1 <- pure a
      Just n2 <- pure b
      m <- compute (n1 + n2) 
      guard (m == 42)
    f2 a _ = do
      Just n <- pure a
      m <- compute n
      guard (m == 42)
    f3 _ b = do
      Just n <- pure b
      m <- compute n
      guard (m == 42)

像execStateT (f (Just 42) (Just 1)) () 这样的调用对于f 会失败，但对于f' 会返回Just ()，因为它匹配f2。

如何获得f' 的行为，同时像f 那样使用尽可能少的辅助定义进行优雅的模式匹配？还有其他更优雅的方式来表达这个吗？

---

完整的可运行示例：

#! /usr/bin/env stack
-- stack --resolver=lts-11.1 script

import Control.Monad.Trans.State
import Control.Applicative
import Control.Monad
import Data.Foldable

compute :: Int -> StateT () Maybe Int
compute = return

f :: Maybe Int -> Maybe Int -> StateT () Maybe ()
f (Just n1) (Just n2) = do
  m <- compute (n1 + n2) 
  guard (m == 42)
f (Just n) _ = do
  m <- compute n
  guard (m == 42)
f _ (Just n) = do
  m <- compute n
  guard (m == 42)

f' :: Maybe Int -> Maybe Int -> StateT () Maybe ()
f' a b = asum (map (\f -> f a b) [f1, f2, f3])
  where
    f1 a b = do
      Just n1 <- pure a
      Just n2 <- pure b
      m <- compute (n1 + n2) 
      guard (m == 42)
    f2 a _ = do
      Just n <- pure a
      m <- compute n
      guard (m == 42)
    f3 _ b = do
      Just n <- pure b
      m <- compute n
      guard (m == 42)

main = do
  print $ execStateT (f (Just 42) (Just 1)) ()  -- Nothing
  print $ execStateT (f' (Just 42) (Just 1)) () -- Just (), because `f2` succeeded

---

编辑：到目前为止，我已经用这个问题得到了一些非常聪明的答案，谢谢！不幸的是，他们大多遭受我给出的特定代码示例的过度拟合。实际上，我需要这样的东西来统一两个表达式（确切地说是 let 绑定），如果可能的话，我想尝试统一两个同时 let 的 RHS 并解决我在一侧处理 let 绑定的情况漂浮它们的时间。所以，实际上Maybe 参数上没有巧妙的结构可以利用，而且我实际上不是computeing Int。

到目前为止的答案可能会使其他人受益，而不仅仅是他们给我带来的启发，所以谢谢！

---

编辑 2：以下是一些可能具有虚假语义的编译示例代码：

module Unify (unify) where

import Control.Applicative
import Control.Monad.Trans.State.Strict

data Expr
  = Var String -- meta, free an bound vars
  | Let String Expr Expr
  -- ... more cases
  -- no Eq instance, fwiw

-- | If the two terms unify, return the most general unifier, e.g.
-- a substitution (`Map`) of meta variables for terms as association
-- list.
unify :: [String] -> Expr -> Expr -> Maybe [(String, Expr)]
unify metaVars l r = execStateT (go [] [] l r) [] -- threads the current substitution as state
  where
    go locals floats (Var x) (Var y)
      | x == y = return ()
    go locals floats (Var x) (Var y)
      | lookup x locals == Just y = return ()
    go locals floats (Var x) e
      | x `elem` metaVars = tryAddSubstitution locals floats x e
    go locals floats e (Var y)
      | y `elem` metaVars = tryAddSubstitution locals floats y e
    -- case in point:
    go locals floats (Let x lrhs lbody) (Let y rrhs rbody) = do
      go locals floats lrhs rrhs -- try this one, fail current pattern branch if rhss don't unify
      -- if we get past the last statement, commit to this branch, no matter
      -- the next statement fails or not
      go ((x,y):locals) floats lbody rbody
    -- try to float the let binding. terms mentioning a floated var might still
    -- unify with a meta var
    go locals floats (Let x rhs body) e = do
      go locals (Left (x,rhs):floats) body e
    go locals floats e (Let y rhs body) = do
      go locals (Right (y,rhs):floats) body e

    go _ _ _ _ = empty

    tryAddSubstitution = undefined -- magic

Answer 1

当我需要这样的东西时，我只需使用 asum 并内联块。这里我也将多个模式Just n1 <- pure a; Just n2 <- pure b浓缩为一个(Just n1, Just n2) <- pure (a, b)。

f :: Maybe Int -> Maybe Int -> StateT () Maybe ()
f a b = asum

  [ do
    (Just n1, Just n2) <- pure (a, b)
    m <- compute (n1 + n2) 
    guard (m == 42)

  , do
    Just n <- pure a
    m <- compute n
    guard (m == 42)

  , do
    Just n <- pure b
    m <- compute n
    guard (m == 42)

  ]

如果您愿意，也可以使用<|> 链：

f :: Maybe Int -> Maybe Int -> StateT () Maybe ()
f a b

  = do
    (Just n1, Just n2) <- pure (a, b)
    m <- compute (n1 + n2) 
    guard (m == 42)

  <|> do
    Just n <- pure a
    m <- compute n
    guard (m == 42)

  <|> do
    Just n <- pure b
    m <- compute n
    guard (m == 42)

对于这种“失败”，这几乎是您所能得到的最低限度。

Answer 2

如果您单独使用Maybe，则可以使用模式保护来做到这一点：

import Control.Monad
import Control.Applicative

ensure :: Alternative f => (a -> Bool) -> a -> f a
ensure p a = a <$ guard (p a)

compute :: Int -> Maybe Int
compute = return

f :: Maybe Int -> Maybe Int -> Maybe Int
f (Just m) (Just n)
    | Just x <- ensure (== 42) =<< compute (m + n)
    = return x
f (Just m) _
    | Just x <- ensure (== 42) =<< compute m
    = return x
f _ (Just n)
    | Just x <- ensure (== 42) =<< compute n
    = return x
f _ _ = empty

（ensure 是一个通用组合子。参见Lift to Maybe using a predicate）

不过，由于您在顶部有 StateT，因此您必须提供一个状态才能在 Maybe 上进行模式匹配，这会搞砸一切。既然如此，你可能会更好地处理你的“丑陋”解决方案。这是改善其外观的异想天开的尝试：

import Control.Monad
import Control.Applicative
import Control.Monad.State
import Control.Monad.Trans
import Data.Foldable

ensure :: Alternative f => (a -> Bool) -> a -> f a
ensure p a = a <$ guard (p a)

compute :: Int -> StateT () Maybe Int
compute = return

f :: Maybe Int -> Maybe Int -> StateT () Maybe Int
f a b = asum (map (\c -> f' (c a b)) [liftA2 (+), const, flip const])
    where
    f' = ensure (== 42) <=< compute <=< lift

虽然这是针对我给出的 sn-p 的特定答案，但重构仅适用于我所面临的代码。

也许将上面的asum 表达式的骨架提取为更通用的组合器并不是那么牵强：

-- A better name would be welcome.
selector :: Alternative f => (a -> a -> a) -> (a -> f b) -> a -> a -> f b
selector g k x y = asum (fmap (\sel -> k (sel x y)) [g, const, flip const])

f :: Maybe Int -> Maybe Int -> StateT () Maybe Int
f = selector (liftA2 (+)) (ensure (== 42) <=< compute <=< lift)

虽然组合器可能有点尴尬，但selector 确实表明该方法比最初看起来更通用：唯一重要的限制是k 必须在某些Alternative 上下文中产生结果.

P.S.：虽然用(<|>) 写selector 而不是asum 可以说更有品味...

selector g k x y = k (g x y) <|> k x <|> k y

...asum 版本直接概括为任意数量的伪模式：

selector :: Alternative f => [a -> a -> a] -> (a -> f b) -> a -> a -> f b
selector gs k x y = asum (fmap (\g -> k (g x y)) gs)

Answer 3

看起来您可以通过以下事实摆脱整个模式匹配：Int 形成带有加法的 Monoid，0 作为标识元素，Maybe a 形成 Monoid如果a 确实如此。那么你的函数就变成了：

f :: Maybe Int -> Maybe Int -> StateT () Maybe Int
f a b = pure $ a <> b >>= compute >>= pure . mfilter (== 42)

您可以通过将谓词作为参数传递来进行概括：

f :: Monoid a => (a -> Bool) -> Maybe a -> Maybe a -> StateT () Maybe a
f p a b = pure $ a <> b >>= compute >>= pure . mfilter p

唯一的问题是compute 现在将Maybe Int 作为输入，但这只是在该函数中调用traverse 并进行任何计算的问题。

---

编辑：考虑到您上次的编辑，我发现如果您将模式匹配分散到可能失败的单独计算中，那么您可以编写

f a b = f1 a b <|> f2 a b <|> f3 a b
  where f1 (Just a) (Just b) = compute (a + b) >>= check
        f1 _        _        = empty
        f2 (Just a) _        = compute a >>= check
        f2 _        _        = empty
        f3 _        (Just b) = compute b >>= check
        f3 _        _        = empty
        check x              = guard (x == 42)