Structurally enforced Free Alternative, without left distributivity

只谈情不闲聊 提交于 2019-12-03 10:44:44

Control.Alternative.Free's Alt f produces a left-distributive Alternative for free, even if f isn't Alternative or f is a non-left-distributive Alternative. We can say that, in addition to the well-agreed upon alternative laws

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

Alt f also gives left-distribution for free.

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

Because Alt f is always left distributive (and runAlt . liftAlt = id) liftAlt can never be a homomorphism for non-left-distributive Alternatives. If an Alternative f is not left-distributive, then there exist a, b, and c such that

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

If liftAlt : f -> Alt f were a homomorphism then

                  (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

To demonstrate this we need an Alternative that isn't left-distributive. Here's one, 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)

Along with some laws for left distribution and right distribution, and some examples

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)

We can demonstrate a few properties of lists, FlipAp lists, and runAlt.

Lists are left-distributive, but FlipAp lists aren't

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]}]

Lists aren't right-distributive, but FlipAp lists are

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 is always left-distributive

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 is never right-distributive

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]}]

We can defile a right-distributive free alternative in terms of FlipAp and 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 is never left-distributive.

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 is always right-distributive

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]}]

Up until now I haven't told you anything that you didn't already imply by saying that liftAlt : f -> Alt f is an Alternative homomorphism, but only for left-distributive Alternative instances. But I have shown you a free-alternative that isn't left-distributive (it's trivially right-distributive instead).

A structurally valid free Alternative

This section answers the bulk of your question, is there a structurally valid free Alternative that isn't left-distributive? Yes.

This isn't an efficient implementation; it's purpose is to demonstrate that it exists and that some version of it can be arrived at in a straight-forward manner.

To make a structurally valid free Alternative I am doing two things. The first is to create a data structure that can't represent any of the Alternative laws; if it can't represent the law then a structure can't be constructed independently of the type class to violate it. This is the same trick used to make lists structurally obey the Alternative associativity law; there's no list that can represent the left-associated (x <|> y) <|> z. The second part is to make sure the operations obey the laws. A list can't represent the left association law, but an implementation of <|> could still violate it, like x <|> y = x ++ reverse y.

The following structure can't be constructed to represent any of the Alternative laws.

{-# 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

It's a 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)

And it's Applicative. Because the structure can't represent the laws, when we encounter a term containing one of the unpreventable expressions we're forced to convert it into something else. The laws tell us what to do.

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)

All of those Aps could be covered by a pair of view patterns, but it doesn't make it any simpler.

It's also an Alternative. For this we'll use a view pattern to divide the cases into the empty and non-empty cases, and an extra type to store the proof that they're non-empty

{-# 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 and 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

This new Alt f doesn't provide either left-distribution or right-distribution for free, and therefore runAlt id :: Alt f a -> g a preserves how distributive g is.

Lists are still left-distributive, but FlipAp lists aren't.

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]}]

List's aren't right-distributive, but FlipAp lists still are

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]}]

Source code for this section

Structurally valid left-catch free Alternative

To control which laws we want we can add them to the structurally free alternative we made earlier.

To add left-catch we'll modify the structure so it can't represent it. Left catch is

(pure a) <|> x = pure a

To keep Alt' from representing it we'll exclude pure from what's allowed to the left of 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

    ...

This results in a compiler error in the implementation of 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)

Which we can fix by appealing to our new law, (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)
易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!