haskell - 结构上强制执行的自由替代，没有左分配

Question

伟大的免费包中有一个不错的免费替代方案，它将 Functor 提升为左分配替代方案。

也就是说，主张是：

runAlt :: Alternative g => (forall x. f x -> g x) -> Alt f a -> g a

是一个替代同态，其中liftAlt. 而且，确实，它是一个，但仅适用于左分布的Alternative 实例。

当然，实际上，很少有替代实例实际上是左分配的。大多数实际重要的替代实例（解析器，大多数 Monad f 的 MaybeT f 等）都不是左分布的。这个事实可以通过一个例子来证明，其中runAlt和liftAlt不形成一个替代同态：

(writeIORef x False <|> writeIORef True) *> (guard =<< readIORef x)
-- is an IO action that throws an exception
runAlt id $ (liftAlt (writeIORef x False) <|> liftAlt (writeIORef True))
               *> liftAlt (guard =<< readIORef x)
-- is an IO action that throws no exception and returns successfully ()

所以runAlt对于一些 Alternatives 来说只是一个 Alternative 同态，但不是全部。这是因为结构Alt 标准化了所有动作以分布在左侧。

Alt很棒，因为从结构上讲，Alt f是合法的Applicative并且Alternative. 没有任何可能的方法来Alt f a使用不遵循法律的 Applicative 和 Alternative 函数构造类型的值......类型本身的结构使其成为免费的替代品。

就像，对于列表，您不能使用不尊重、、和关联性的<>和构造列表。memptyx <> mempty = xmempty <> x = x

我编写了一个 Free 替代方案，它在结构上不强制执行 Applicative 和 Alternative 定律，但使用 runAlt/liftAlt 产生了一个有效的 Alternative 和 Applicative 同态：

data Alt :: (* -> *) -> * -> * where
    Pure  :: a   -> Alt f a
    Lift  :: f a -> Alt f a
    Empty :: Alt f a
    Ap    :: Alt f (a -> b) -> Alt f a -> Alt f b
    Plus  :: Alt f as -> Alt f as -> Alt f as

instance Functor f => Functor (Alt f) where
    fmap f = \case
      Pure x     -> Pure (f x)
      Lift x     -> Lift (f <$> x)
      Empty      -> Empty
      Ap fs xs   -> Ap ((f .) <$> fs) xs
      Plus xs ys -> Plus (f <$> xs) (f <$> ys)

instance Functor f => Applicative (Alt f) where
    pure  = Pure
    (<*>) = Ap

instance Functor f => Alternative (Alt f) where
    empty = Empty
    (<|>) = Plus

在结构上，Alt f不是实际的Applicative，因为：

pure f <*> pure x = Ap (Pure f) (Pure x)
pure (f x)        = Pure (f x)

所以pure f <*> pure x在pure (f x)结构上与 不同。不是一个有效的应用程序，马上。

但是，使用给定的runAltand liftAlt：

liftAlt :: f a -> Alt f a
liftAlt = Lift

runAlt :: Alternative g => (forall x. f x -> g x) -> Alt f a -> g a
runAlt f = \case
  Pure x     -> pure x
  Lift x     -> f x
  Empty      -> empty
  Ap fs xs   -> runAlt f fs <*> runAlt f xs
  Plus xs ys -> runAlt f xs <|> runAlt f ys

这里runAlt确实可以作为一个有效的应用同态与给定的自然变换......

有人可以说我的 newAlt f是一个有效的 Alternative 和 Applicative，当被 定义的等价关系商时runAlt，我想。

无论如何，这只是有点不满意。有没有办法编写一个免费的替代方案，它在结构上是一个有效的替代方案和应用程序，而不强制执行左分配？

（特别是，我实际上对遵循左捕获法并在结构上执行它的方法感兴趣。这将是一件单独且有趣的事情，但并非完全必要。）

而且，如果没有任何办法，为什么不呢？

Answer 1

Control.Alternative.Free's免费Alt f产生左分配Alternative，即使fis notAlternative或fis non-left-distributive Alternative。我们可以说，除了公认的替代法律

empty <|> x = x
x <|> empty = x
(x <|> y) <|> z = x <|> (y <|> z)
empty <*> f = empty

Alt f还免费提供左分配。

(a <|> b) <*> c = (a <*> c) <|> (b <*> c)

因为Alt f总是左分配的 (and runAlt . liftAlt = id)liftAlt永远不可能是非左分配Alternative的 s 的同态。如果 anAlternative f不是左分配的，则存在a, b,c等使得

(a <|> b) <*> c != (a <*> c) <|> (b <*> c)

如果liftAlt : f -> Alt f是同态那么

                  (a <|> b) <*> c  !=                   (a <*> c) <|> (b <*> c)                                       -- f is not left-distributive
id               ((a <|> b) <*> c) != id               ((a <*> c) <|> (b <*> c))
runAlt . liftAlt ((a <|> b) <*> c) != runAlt . liftAlt ((a <*> c) <|> (b <*> c))                                      -- runAlt . liftAlt = id
runAlt ((liftAlt a <|> liftAlt b) <*> liftAlt c) != runAlt ((liftAlt a <*> liftAlt c) <|> (liftAlt b <*> liftAlt c))  -- homomorphism
runAlt ((liftAlt a <|> liftAlt b) <*> liftAlt c) != runAlt ((liftAlt a <|> liftAlt b) <*> liftAlt c)                  -- by left-distribution of `Alt`, this is a contradiction

为了证明这一点，我们需要一个Alternative不是左分配的。这里有一个，FlipAp []。

newtype FlipAp f a = FlipAp {unFlipAp :: f a}
  deriving Show

instance Functor f => Functor (FlipAp f) where
    fmap f (FlipAp x) = FlipAp (fmap f x)

instance Applicative f => Applicative (FlipAp f) where
    pure = FlipAp . pure
    (FlipAp f) <*> (FlipAp xs) = FlipAp ((flip ($) <$> xs) <*> f)

instance Alternative f => Alternative (FlipAp f) where
    empty = FlipAp empty
    (FlipAp a) <|> (FlipAp b) = FlipAp (a <|> b)

以及一些左分配和右分配的规律，以及一些例子

leftDist :: Alternative f => f (x -> y) -> f (x -> y) -> f x -> Example (f y)
leftDist a b c = [(a <|> b) <*> c, (a <*> c) <|> (b <*> c)]

rightDist :: Alternative f => f (x -> y) -> f x -> f x -> Example (f y)
rightDist a b c = [a <*> (b <|> c), (a <*> b) <|> (a <*> c)]

type Example a = [a]

ldExample1 :: Alternative f => Example (f Int)
ldExample1 = leftDist (pure (+1)) (pure (*10)) (pure 2 <|> pure 3)

rdExample1 :: Alternative f => Example (f Int)
rdExample1 = rightDist (pure (+1) <|> pure (*10)) (pure 2) (pure 3)

我们可以演示列表、FlipAp列表和runAlt.

列表是左分布的，但FlipAp列表不是

ldExample1 :: Example [Int]
ldExample1 :: Example (FlipAp [] Int)

[[3,4,20,30],[3,4,20,30]]
[FlipAp {unFlipAp = [3,20,4,30]},FlipAp {unFlipAp = [3,4,20,30]}]

列表不是右分配的，但FlipAp列表是

rdExample1 :: Example [Int]
rdExample1 :: Example (FlipAp [] Int)

[[3,4,20,30],[3,20,4,30]]
[FlipAp {unFlipAp = [3,20,4,30]},FlipAp {unFlipAp = [3,20,4,30]}]

Alt总是左分配的

map (runAlt id) ldExample1 :: Example [Int]
map (runAlt id) ldExample1 :: Example (FlipAp [] Int)

[[3,4,20,30],[3,4,20,30]]
[FlipAp {unFlipAp = [3,4,20,30]},FlipAp {unFlipAp = [3,4,20,30]}]

Alt永远不是右分配的

map (runAlt id) rdExample1 :: Example [Int]
map (runAlt id) rdExample1 :: Example (FlipAp [] Int)

[[3,4,20,30],[3,20,4,30]]
[FlipAp {unFlipAp = [3,4,20,30]},FlipAp {unFlipAp = [3,20,4,30]}]

FlipAp我们可以根据和玷污一个右分配的自由选择Alt。

runFlipAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> FlipAp (Alt f) a -> g a
runFlipAlt nt = runAlt nt . unFlipAp

FlipAp Alt绝不是左分配的。

map (runFlipAlt id) ldExample1 :: Example [Int]
map (runFlipAlt id) ldExample1 :: Example (FlipAp [] Int)

[[3,20,4,30],[3,4,20,30]]
[FlipAp {unFlipAp = [3,20,4,30]},FlipAp {unFlipAp = [3,4,20,30]}]

FlipAp Alt总是右分配的

map (runFlipAlt id) rdExample1 :: Example [Int]
map (runFlipAlt id) rdExample1 :: Example (FlipAp [] Int)

[[3,20,4,30],[3,20,4,30]]
[FlipAp {unFlipAp = [3,20,4,30]},FlipAp {unFlipAp = [3,20,4,30]}]

到目前为止，我还没有告诉你任何你还没有通过说这liftAlt : f -> Alt f是Alternative同态来暗示的事情，但仅适用于左分布的Alternative 实例。但是我已经向您展示了一个不是左分配的自由替代方案（它只是微不足道的右分配）。

结构上有效的自由Alternative

本节回答了您的大部分问题，是否存在非左分配的结构上有效的自由？Alternative是的。

这不是一个有效的实现；它的目的是证明它存在并且可以以直接的方式得到它的某个版本。

为了使结构上有效的自由Alternative，我做两件事。首先是创建一个不能代表任何Alternative规律的数据结构；如果它不能代表法律，那么就不能独立于类型类来构造一个结构来违反它。Alternative这与使列表在结构上服从结合律的技巧相同；没有可以代表左关联的列表(x <|> y) <|> z。第二部分是确保操作遵守法律。列表不能代表左关联法，但 的实现<|>仍然可能违反它，例如x <|> y = x ++ reverse y.

不能构造以下结构来代表任何Alternative法律。

{-# Language GADTs #-}
{-# Language DataKinds #-}
{-# Language KindSignatures #-}

data Alt :: (* -> *) -> * -> * where
    Alt :: Alt' empty pure plus f a -> Alt f a

--           empty   pure    plus
data Alt' :: Bool -> Bool -> Bool -> (* -> *) -> * -> * where
    Empty ::        Alt' True  False False f a
    Pure  :: a   -> Alt' False True  False f a
    Lift  :: f a -> Alt' False False False f a

    Plus  :: Alt' False pure1 False f a -> Alt' False pure2 plus2 f a -> Alt' False False True  f a
      -- Empty can't be to the left or right of Plus
      -- empty <|> x = x
      -- x <|> empty = x

      -- Plus can't be to the left of Plus
      -- (x <|> y) <|> z = x <|> (y <|> z)
    Ap    :: Alt' False False plus1 f (a -> b) -> Alt' empty False plus2 f a -> Alt' False False False f b
      -- Empty can't be to the left of `Ap`
      -- empty <*> f = empty

      -- Pure can't be to the left or right of `Ap`
      -- pure id <*> v = v     
      -- pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
      -- pure f <*> pure x = pure (f x)
      -- u <*> pure y = pure ($ y) <*> u

它是Functor

instance Functor f => Functor (Alt' empty pure plus f) where
    fmap _ Empty       = Empty
    fmap f (Pure a)    = Pure (f a)
    fmap f (Plus a as) = Plus (fmap f a) (fmap f as)
    fmap f (Lift a)    = Lift (fmap f a)
    fmap f (Ap g a)    = Ap (fmap (f .) g) a

instance Functor f => Functor (Alt f) where
    fmap f (Alt a) = Alt (fmap f a)

它是Applicative。因为结构不能代表规律，所以当我们遇到一个包含无法预防的表达的术语时，我们被迫将其转换为其他东西。法律告诉我们该怎么做。

instance Functor f => Applicative (Alt f) where
    pure a = Alt (Pure a)

    Alt Empty <*> _ = Alt Empty                          -- empty <*> f = empty
    Alt (Pure f) <*> (Alt x) = Alt (fmap f x)            -- pure f <*> x = fmap f x          (free theorem)
    Alt u <*> (Alt (Pure y)) = Alt (fmap ($ y) u)        -- u <*> pure y = pure ($ y) <*> u
    Alt f@(Lift _)   <*> Alt x@Empty      = Alt (Ap f x)
    Alt f@(Lift _)   <*> Alt x@(Lift _)   = Alt (Ap f x)
    Alt f@(Lift _)   <*> Alt x@(Plus _ _) = Alt (Ap f x)
    Alt f@(Lift _)   <*> Alt x@(Ap _ _)   = Alt (Ap f x)
    Alt f@(Plus _ _) <*> Alt x@Empty      = Alt (Ap f x)
    Alt f@(Plus _ _) <*> Alt x@(Lift _)   = Alt (Ap f x)
    Alt f@(Plus _ _) <*> Alt x@(Plus _ _) = Alt (Ap f x)
    Alt f@(Plus _ _) <*> Alt x@(Ap _ _)   = Alt (Ap f x)
    Alt f@(Ap _ _)   <*> Alt x@Empty      = Alt (Ap f x)
    Alt f@(Ap _ _)   <*> Alt x@(Lift _)   = Alt (Ap f x)
    Alt f@(Ap _ _)   <*> Alt x@(Plus _ _) = Alt (Ap f x)
    Alt f@(Ap _ _)   <*> Alt x@(Ap _ _)   = Alt (Ap f x)

所有这些Aps 都可以被一对视图模式覆盖，但这并没有让它变得更简单。

它也是一个Alternative. 为此，我们将使用视图模式将案例分为空案例和非空案例，以及一个额外的类型来存储它们非空的证明

{-# Language ViewPatterns #-}

import Control.Applicative

data AltEmpty :: (* -> *) -> * -> * where
    Empty_    :: Alt' True  False False f a -> AltEmpty f a
    NonEmpty_ :: AltNE f a -> AltEmpty f a

data AltNE :: (* -> *) -> * -> * where
    AltNE :: Alt' False pure plus f a -> AltNE f a

empty_ :: Alt' e1 p1 p2 f a -> AltEmpty f a
empty_ x@Empty      = Empty_ x
empty_ x@(Pure _)   = NonEmpty_ (AltNE x)
empty_ x@(Lift _)   = NonEmpty_ (AltNE x)
empty_ x@(Plus _ _) = NonEmpty_ (AltNE x)
empty_ x@(Ap _ _)   = NonEmpty_ (AltNE x)

instance Functor f => Alternative (Alt f) where
    empty = Alt Empty

    Alt Empty <|> x = x                                 -- empty <|> x = x
    x <|> Alt Empty = x                                 -- x <|> empty = x
    Alt (empty_ -> NonEmpty_ a) <|> Alt (empty_ -> NonEmpty_ b) = case a <> b of AltNE c -> Alt c
      where
        (<>) :: AltNE f a -> AltNE f a -> AltNE f a
        AltNE (Plus x y) <> AltNE z = AltNE x <> (AltNE y <> AltNE z)  -- (x <|> y) <|> x = x <|> (y <|> z)
        AltNE a@(Pure _) <> AltNE b = AltNE (Plus a b)
        AltNE a@(Lift _) <> AltNE b = AltNE (Plus a b)
        AltNE a@(Ap _ _) <> AltNE b = AltNE (Plus a b)

liftAlt和runAlt

{-# Language RankNTypes #-}
{-# Language ScopedTypeVariables #-}

liftAlt :: f a -> Alt f a
liftAlt = Alt . Lift

runAlt' :: forall f g x empty pure plus a. Alternative g => (forall x. f x -> g x) -> Alt' empty pure plus f a -> g a
runAlt' u = go
  where
    go :: forall empty pure plus a. Alt' empty pure plus f a -> g a
    go Empty    = empty
    go (Pure a) = pure a
    go (Lift a) = u a
    go (Plus x y) = go x <|> go y
    go (Ap f x)   = go f <*> go x

runAlt :: Alternative g => (forall x. f x -> g x) -> Alt f a -> g a
runAlt u (Alt x) = runAlt' u x

这个新Alt f的不提供免费的左分配或右分配，因此runAlt id :: Alt f a -> g a保留了分配g的方式。

列表仍然是左分配的，但FlipAp列表不是。

map (runAlt id) ldExample1 :: Example [Int]
map (runAlt id) ldExample1 :: Example (FlipAp [] Int)

[[3,4,20,30],[3,4,20,30]]
[FlipAp {unFlipAp = [3,20,4,30]},FlipAp {unFlipAp = [3,4,20,30]}]

列表不是右分配的，但FlipAp列表仍然是

map (runAlt id) rdExample1 :: Example [Int]
map (runAlt id) rdExample1 :: Example (FlipAp [] Int)

[[3,4,20,30],[3,20,4,30]]
[FlipAp {unFlipAp = [3,20,4,30]},FlipAp {unFlipAp = [3,20,4,30]}]

本节的源代码

结构上有效的left-catch freeAlternative

为了控制我们想要的法律，我们可以将它们添加到我们之前制作的结构自由替代方案中。

要添加 left-catch，我们将修改结构，使其无法表示。左接球是

(纯a) <|> x = 纯a

为了Alt'避免表示它，我们将从.pure左侧允许的内容中排除Plus。

--           empty   pure    plus
data Alt' :: Bool -> Bool -> Bool -> (* -> *) -> * -> * where
    Empty ::        Alt' True  False False f a
    Pure  :: a   -> Alt' False True  False f a
    Lift  :: f a -> Alt' False False False f a

    Plus  :: Alt' False False False f a -> Alt' False pure2 plus2 f a -> Alt' False False True  f a
      -- Empty can't be to the left or right of Plus
      -- empty <|> x = x
      -- x <|> empty = x

      -- Plus can't be to the left of Plus
      -- (x <|> y) <|> z = x <|> (y <|> z)

      -- Pure can't be to the left of Plus
      -- (pure a) <|> x = pure a

    ...

这会导致在执行时出现编译器错误Alternative Alt

Couldn't match type ‘'True’ with ‘'False’
Expected type: Alt' 'False 'False 'False f a1
  Actual type: Alt' 'False pure2 plus2 f a1
In the first argument of ‘Plus’, namely ‘a’
In the first argument of ‘AltNE’, namely ‘(Plus a b)

我们可以通过诉诸我们的新法律来解决这个问题，(pure a) <|> x = pure a

instance Functor f => Alternative (Alt f) where
    empty = Alt Empty

    Alt Empty <|> x = x                                 -- empty <|> x = x
    x <|> Alt Empty = x                                 -- x <|> empty = x
    Alt (empty_ -> NonEmpty_ a) <|> Alt (empty_ -> NonEmpty_ b) = case a <> b of AltNE c -> Alt c
      where
        (<>) :: AltNE f a -> AltNE f a -> AltNE f a
        AltNE a@(Pure _) <> _ = AltNE a                                -- (pure a) <|> x = pure a
        AltNE (Plus x y) <> AltNE z = AltNE x <> (AltNE y <> AltNE z)  -- (x <|> y) <|> x = x <|> (y <|> z)
        AltNE a@(Lift _) <> AltNE b = AltNE (Plus a b)
        AltNE a@(Ap _ _) <> AltNE b = AltNE (Plus a b)