Merge remote-tracking branch 'origin/master' into error-syntax

semantic-diff.cabal

@@ -21,6 +21,8 @@ library
                      , Data.Functor.Both
                      , Data.RandomWalkSimilarity
                      , Data.Record
+                     , Data.Mergeable
+                     , Data.Mergeable.Generic
                      , Data.These.Arbitrary
                      , Diff
                      , Diff.Arbitrary
@@ -103,6 +105,7 @@ test-suite semantic-diff-test
   main-is:             Spec.hs
   other-modules:       AlignmentSpec
                      , CorpusSpec
+                     , Data.Mergeable.Spec
                      , Data.RandomWalkSimilarity.Spec
                      , Diff.Spec
                      , DiffSummarySpec

src/Alignment.hs

@@ -61,42 +61,11 @@ alignPatch sources patch = case patch of
 
 -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff.
 alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) (Record fields) term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term]
-alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = case syntax of
-  Leaf s -> catMaybes $ wrapInBranch (const (Leaf s)) . fmap (flip (,) []) <$> (Join <$> bisequenceL (runJoin lineRanges))
-  Comment a -> catMaybes $ wrapInBranch (const (Comment a)) . fmap (flip (,) []) <$> (Join <$> bisequenceL (runJoin lineRanges))
-  Indexed children ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges
-  Syntax.Error children ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges
-  Syntax.Function id params body -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (fromMaybe [] id <> fromMaybe []  params <> body) bothRanges
-  -- Align FunctionCalls like Indexed nodes by appending identifier to its children.
-  Syntax.FunctionCall identifier children ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join (identifier : children)) bothRanges
-  Syntax.Assignment assignmentId value ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (assignmentId <> value) bothRanges
-  Syntax.MemberAccess memberId property ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (memberId <> property) bothRanges
-  Syntax.MethodCall targetId methodId args ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (targetId <> methodId <> args) bothRanges
-  Syntax.Args children ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges
-  Syntax.VarDecl decl ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange decl bothRanges
-  Syntax.VarAssignment id value ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (id <> value) bothRanges
-  Switch expr cases ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges
-  Case expr body ->
-    catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (expr <> body) bothRanges
-  Fixed children ->
-    catMaybes $ wrapInBranch Fixed <$> alignBranch getRange (join children) bothRanges
-  Pair a b -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (a <> b) bothRanges
-  Object children -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges
-  Commented cs expr -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join cs <> join (maybeToList expr)) bothRanges
-  Ternary expr cases -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (expr <> join cases) bothRanges
-  Operator cases -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join cases) bothRanges
-  MathAssignment key value -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges
-  SubscriptAccess key value -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (key <> value) bothRanges
+alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = catMaybes $ case syntax of
+  Leaf s -> wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges
+  Comment a -> wrapInBranch (const (Comment a)) <$> alignBranch getRange [] bothRanges
+  Fixed children -> wrapInBranch Fixed <$> alignBranch getRange (join children) bothRanges
+  _ -> wrapInBranch Indexed <$> alignBranch getRange (join (toList syntax)) bothRanges
   where bothRanges = modifyJoin (fromThese [] []) lineRanges
         lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources
         wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (setCharacterRange info range :< constructor children)) <$> infos)

src/Data/Mergeable.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE DefaultSignatures #-}
+module Data.Mergeable where
+
+import Data.Functor.Identity
+import Data.Mergeable.Generic
+import GHC.Generics
+import Prologue
+
+-- 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, we can use 'merge' to select one side or the other of a diff node in 'Syntax', while correctly handling the fact that some patches don’t have any content for that side:
+--
+-- @
+-- let before = iter (\ (a :< s) -> cofree . (fst a :<) <$> sequenceAlt syntax) . fmap (maybeFst . unPatch)
+-- @
+class Functor t => Mergeable t where
+  -- | Merge a functor by mapping its elements into an 'Alternative' functor, combining them, and pushing the 'Mergeable' functor inside.
+  merge :: Alternative f => (a -> f b) -> t a -> f (t b)
+  default merge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b)
+  merge = genericMerge
+
+  -- | Sequnce a 'Mergeable' functor by 'merge'ing the 'Alternative' values.
+  sequenceAlt :: Alternative f => t (f a) -> f (t a)
+  sequenceAlt = merge identity
+
+
+-- Instances
+
+instance Mergeable [] where merge = gmerge
+
+instance Mergeable Maybe
+
+instance Mergeable Identity where merge f = fmap Identity . f . runIdentity

src/Data/Mergeable/Generic.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeOperators #-}
+module Data.Mergeable.Generic where
+
+import GHC.Generics
+import Prologue
+
+-- Classes
+
+class GMergeable t where
+  gmerge :: Alternative f => (a -> f b) -> t a -> f (t b)
+
+genericMerge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b)
+genericMerge f = fmap to1 . gmerge f . from1
+
+
+-- Instances
+
+instance GMergeable U1 where
+  gmerge _ _ = pure U1
+
+instance GMergeable Par1 where
+  gmerge f (Par1 a) = Par1 <$> f a
+
+instance GMergeable (K1 i c) where
+  gmerge _ (K1 a) = pure (K1 a)
+
+instance GMergeable f => GMergeable (Rec1 f) where
+  gmerge f (Rec1 a) = Rec1 <$> gmerge f a
+
+instance GMergeable f => GMergeable (M1 i c f) where
+  gmerge f (M1 a) = M1 <$> gmerge f a
+
+instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where
+  gmerge f (L1 a) = L1 <$> gmerge f a
+  gmerge f (R1 b) = R1 <$> gmerge f b
+
+instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where
+  gmerge f (a :*: b) = (:*:) <$> gmerge f a <*> gmerge f b
+
+instance GMergeable [] where
+  gmerge f (x:xs) = ((:) <$> f x <|> pure identity) <*> gmerge f xs
+  gmerge _ [] = pure []
+
+instance GMergeable Maybe where
+  gmerge f (Just a) = Just <$> f a
+  gmerge _ Nothing = pure empty

src/Diff.hs

@@ -5,6 +5,7 @@ module Diff where
 import Prologue
 import Data.Functor.Foldable as Foldable
 import Data.Functor.Both as Both
+import Data.Mergeable
 import Patch
 import Syntax
 import Term
@@ -28,10 +29,7 @@ diffCost = diffSum $ patchSum termSize
 mergeMaybe :: (Patch (Term leaf annotation) -> Maybe (Term leaf annotation)) -> Diff leaf annotation -> Maybe (Term leaf annotation)
 mergeMaybe transform = iter algebra . fmap transform
   where algebra :: CofreeF (Syntax leaf) (Both annotation) (Maybe (Term leaf annotation)) -> Maybe (Term leaf annotation)
-        algebra (annotations :< syntax) = Just . cofree $ Both.fst annotations :< case syntax of
-          Leaf s -> Leaf s
-          Indexed i -> Indexed (catMaybes i)
-          Fixed i -> Fixed (catMaybes i)
+        algebra (annotations :< syntax) = cofree . (Both.fst annotations :<) <$> sequenceAlt syntax
 
 -- | Recover the before state of a diff.
 beforeTerm :: Diff leaf annotation -> Maybe (Term leaf annotation)

src/Syntax.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Syntax where
 
-import Prologue
+import Data.Mergeable
 import GHC.Generics
+import Prologue
 import Test.QuickCheck hiding (Fixed)
 
 -- | A node in an abstract syntax tree.
@@ -50,7 +52,7 @@ data Syntax
   | Comment a
   | Commented [f] (Maybe f)
   | Error [f]
-  deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
+  deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable)
 
 
 -- Instances

test/Data/Mergeable/Spec.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
+module Data.Mergeable.Spec where
+
+import Data.Functor.Identity
+import Data.Mergeable
+import Prologue
+import Syntax
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+
+spec :: Spec
+spec = parallel $ do
+  describe "[]" $ do
+    let gen = scale (`div` 25) arbitrary :: Gen [Char]
+    withAlternativeInstances sequenceAltLaws gen
+    withAlternativeInstances mergeLaws gen
+  describe "Maybe" $ do
+    withAlternativeInstances sequenceAltLaws (arbitrary :: Gen (Maybe Char))
+    withAlternativeInstances mergeLaws (arbitrary :: Gen (Maybe Char))
+  describe "Identity" $ do
+    withAlternativeInstances sequenceAltLaws (Identity <$> arbitrary :: Gen (Identity Char))
+    withAlternativeInstances mergeLaws (Identity <$> arbitrary :: Gen (Identity Char))
+  describe "Syntax" $ do
+    withAlternativeInstances sequenceAltLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char))
+    withAlternativeInstances mergeLaws (sized (syntaxOfSize (const arbitrary)) :: Gen (Syntax Char Char))
+
+  prop "subsumes catMaybes/Just" $ do
+    \ a -> sequenceAlt a `shouldBe` pure (catMaybes (a :: [Maybe Char]))
+
+mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec
+mergeLaws value function = describe "merge" $ do
+  prop "identity" . forAll value $
+    \ a -> merge pure a `shouldNotBe` (empty :: g (f a))
+
+  let pair = (,) <$> value <*> function
+  prop "relationship with sequenceAlt" . forAll pair $
+    \ (a, f) -> merge (getBlind f) a `shouldBe` sequenceAlt (fmap (getBlind f) a)
+
+sequenceAltLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec
+sequenceAltLaws value function = do
+  describe "sequenceAlt" $ do
+    prop "identity" . forAll value $
+      \ a -> sequenceAlt (pure <$> a) `shouldNotBe` (empty :: g (f a))
+
+    prop "relationship with merge" . forAll (Blind <$> (fmap . getBlind <$> function <*> value) :: Gen (Blind (f (g a)))) $
+      \ a -> sequenceAlt (getBlind a) `shouldBe` merge identity (getBlind a)
+
+
+withAlternativeInstances :: forall f a. (Arbitrary a, CoArbitrary a, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => Gen (f a) -> Gen (Blind (a -> g a)) -> Spec) -> Gen (f a) -> Spec
+withAlternativeInstances laws gen = do
+  describe "[]" $ laws gen (scale (`div` 25) (arbitrary :: Gen (Blind (a -> [a]))))
+  describe "Maybe" $ laws gen (arbitrary :: Gen (Blind (a -> Maybe a)))

test/Spec.hs

@@ -3,6 +3,7 @@ module Main where
 import Prologue
 import qualified AlignmentSpec
 import qualified CorpusSpec
+import qualified Data.Mergeable.Spec
 import qualified Data.RandomWalkSimilarity.Spec
 import qualified Diff.Spec
 import qualified DiffSummarySpec
@@ -15,6 +16,7 @@ main :: IO ()
 main = hspec . parallel $ do
   describe "Alignment" AlignmentSpec.spec
   describe "Corpus" CorpusSpec.spec
+  describe "Data.Mergeable" Data.Mergeable.Spec.spec
   describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec
   describe "Diff.Spec" Diff.Spec.spec
   describe "DiffSummary" DiffSummarySpec.spec