mirror of
https://github.com/github/semantic.git
synced 2024-12-21 13:51:44 +03:00
75 lines
2.7 KiB
Haskell
75 lines
2.7 KiB
Haskell
{-# LANGUAGE DefaultSignatures, TypeOperators, UndecidableInstances #-}
|
||
module Data.Mergeable ( Mergeable (..) ) where
|
||
|
||
import Control.Applicative
|
||
import Data.Functor.Identity
|
||
import Data.List.NonEmpty
|
||
import Data.Sum
|
||
import GHC.Generics
|
||
|
||
-- Classes
|
||
|
||
-- | A 'Mergeable' functor is one which supports pushing itself through an 'Alternative' functor. Note the similarities with 'Traversable' & 'Crosswalk'.
|
||
--
|
||
-- This is a kind of distributive law which produces (at least) the union of the two functors’ shapes; i.e. unlike 'Traversable', an 'empty' value in the inner functor does not produce an 'empty' result, and unlike 'Crosswalk', an 'empty' value in the outer functor does not produce an 'empty' result.
|
||
--
|
||
-- For example, 'Data.Diff' uses 'sequenceAlt' to select one side or the other of a diff node, while correctly handling the fact that some patches don’t have any content for that side.
|
||
class Functor t => Mergeable t where
|
||
-- | Sequence a 'Mergeable' functor by merging the 'Alternative' values.
|
||
sequenceAlt :: Alternative f => t (f a) -> f (t a)
|
||
default sequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a)
|
||
sequenceAlt = genericSequenceAlt
|
||
|
||
|
||
-- Instances
|
||
|
||
instance Mergeable [] where
|
||
sequenceAlt = foldr (\ x -> (((:) <$> x <|> pure id) <*>)) (pure [])
|
||
|
||
instance Mergeable NonEmpty where
|
||
sequenceAlt (x :|[]) = (:|) <$> x <*> pure []
|
||
sequenceAlt (x1:|x2:xs) = (:|) <$> x1 <*> sequenceAlt (x2 : xs) <|> sequenceAlt (x2:|xs)
|
||
|
||
instance Mergeable Maybe where
|
||
sequenceAlt = maybe (pure empty) (fmap Just)
|
||
|
||
instance Mergeable Identity where
|
||
sequenceAlt = fmap Identity . runIdentity
|
||
|
||
instance (Apply Functor fs, Apply Mergeable fs) => Mergeable (Sum fs) where
|
||
sequenceAlt = apply' @Mergeable (\ reinj t -> reinj <$> sequenceAlt t)
|
||
|
||
|
||
-- Generics
|
||
|
||
class GMergeable t where
|
||
gsequenceAlt :: Alternative f => t (f a) -> f (t a)
|
||
|
||
genericSequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a)
|
||
genericSequenceAlt = fmap to1 . gsequenceAlt . from1
|
||
|
||
|
||
-- Instances
|
||
|
||
instance GMergeable U1 where
|
||
gsequenceAlt _ = pure U1
|
||
|
||
instance GMergeable Par1 where
|
||
gsequenceAlt (Par1 a) = Par1 <$> a
|
||
|
||
instance GMergeable (K1 i c) where
|
||
gsequenceAlt (K1 a) = pure (K1 a)
|
||
|
||
instance Mergeable f => GMergeable (Rec1 f) where
|
||
gsequenceAlt (Rec1 a) = Rec1 <$> sequenceAlt a
|
||
|
||
instance GMergeable f => GMergeable (M1 i c f) where
|
||
gsequenceAlt (M1 a) = M1 <$> gsequenceAlt a
|
||
|
||
instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where
|
||
gsequenceAlt (L1 a) = L1 <$> gsequenceAlt a
|
||
gsequenceAlt (R1 a) = R1 <$> gsequenceAlt a
|
||
|
||
instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where
|
||
gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b
|