1
1
mirror of https://github.com/github/semantic.git synced 2024-12-25 16:02:43 +03:00

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

This commit is contained in:
joshvera 2016-07-27 19:00:27 -04:00
commit 8b0f496b90
8 changed files with 152 additions and 42 deletions

View File

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

View File

@ -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. -- | 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 :: (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 alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = catMaybes $ case syntax of
Leaf s -> catMaybes $ wrapInBranch (const (Leaf s)) . fmap (flip (,) []) <$> (Join <$> bisequenceL (runJoin lineRanges)) Leaf s -> wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges
Comment a -> catMaybes $ wrapInBranch (const (Comment a)) . fmap (flip (,) []) <$> (Join <$> bisequenceL (runJoin lineRanges)) Comment a -> wrapInBranch (const (Comment a)) <$> alignBranch getRange [] bothRanges
Indexed children -> Fixed children -> wrapInBranch Fixed <$> alignBranch getRange (join children) bothRanges
catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges _ -> wrapInBranch Indexed <$> alignBranch getRange (join (toList syntax)) 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
where bothRanges = modifyJoin (fromThese [] []) lineRanges where bothRanges = modifyJoin (fromThese [] []) lineRanges
lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources
wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (setCharacterRange info range :< constructor children)) <$> infos) wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (setCharacterRange info range :< constructor children)) <$> infos)

37
src/Data/Mergeable.hs Normal file
View File

@ -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 dont 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

View File

@ -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

View File

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

View File

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

View File

@ -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)))

View File

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