Merge branch 'master' into syntax-redux

HLint.hs

@@ -14,4 +14,6 @@ error "Avoid return" =
     where note = "return is obsolete as of GHC 7.10"
 
 error "use pure" = free . Pure ==> pure
+error "use wrap" = free . Free ==> wrap
+
 error "use extract" = headF . runCofree ==> extract

bench/Main.hs

@@ -1,25 +1,41 @@
 {-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleInstances, StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Main where
 
 import Criterion.Main
+import Data.Function
+import Data.List (genericLength)
 import Data.String
+import Patch
 import Prologue
+import SES
 import Test.QuickCheck hiding (Fixed)
 
 main :: IO ()
 main = do
-  benchmarks <- sequenceA []
+  benchmarks <- sequenceA [ generativeBenchmarkWith "ses" 10 arbitrarySESInputs (uncurry ((*) `on` length)) (nf (uncurry benchmarkSES)) ]
   defaultMain benchmarks
+  where arbitrarySESInputs = (,) <$> sized (`vectorOf` arbitrary) <*> sized (`vectorOf` arbitrary)
+
+benchmarkSES :: [String] -> [String] -> [Either String (Patch String)]
+benchmarkSES as bs = ses compare cost as bs
+  where compare a b = if a == b then Just (Left a) else Nothing
+        cost = either (const 0) (sum . fmap genericLength)
+
+instance NFData a => NFData (Patch a)
 
 -- | Defines a named group of n benchmarks over inputs generated by an `Arbitrary` instance.
 -- |
 -- | The inputs’ sizes at each iteration are measured by a metric function, which gives the name of the benchmark. This makes it convenient to correlate a benchmark of some function over lists with e.g. input `length`.
 generativeBenchmark :: (Arbitrary a, Show m, Ord m) => String -> Int -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
-generativeBenchmark name n metric benchmark = do
-  benchmarks <- traverse measure (replicate n defaultSize)
+generativeBenchmark name n metric benchmark = generativeBenchmarkWith name n arbitrary metric benchmark
+
+generativeBenchmarkWith :: (Show m, Ord m) => String -> Int -> Gen a -> (a -> m) -> (a -> Benchmarkable) -> IO Benchmark
+generativeBenchmarkWith name n generator metric benchmark = do
+  benchmarks <- traverse measure (take n [0,(defaultSize `div` n)..defaultSize])
   pure $! bgroup name (snd <$> (sortOn fst benchmarks))
   where measure n = do
-          input <- generate (resize n arbitrary)
+          input <- generate (resize n generator)
           let measurement = metric input
           pure $! (measurement, bench (show measurement) (benchmark input))
         defaultSize = 100

semantic-diff.cabal

@@ -16,6 +16,7 @@ library
   exposed-modules:     Algorithm
                      , Alignment
                      , Category
+                     , Data.Align.Generic
                      , Data.Bifunctor.Join.Arbitrary
                      , Data.Functor.Both
                      , Data.RandomWalkSimilarity

src/Data/Align/Generic.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE DefaultSignatures, TypeOperators #-}
+module Data.Align.Generic where
+
+import Control.Monad
+import Data.Align
+import Data.These
+import GHC.Generics
+import Data.OrderedMap
+import Prologue
+import Syntax
+
+-- | Functors which can be aligned (structure-unioning-ly zipped). The default implementation will operate generically over the constructors in the aligning type.
+class Functor f => GAlign f where
+  galign :: f a -> f b -> Maybe (f (These a b))
+  default galign :: (Generic1 f, GAlign (Rep1 f)) => f a -> f b -> Maybe (f (These a b))
+  galign a b = to1 <$> galign (from1 a) (from1 b)
+
+
+-- Generically-derived instances
+
+instance Eq a => GAlign (Syntax a)
+
+
+-- 'Data.Align.Align' instances
+
+instance GAlign [] where galign = galignAlign
+instance GAlign Maybe where galign = galignAlign
+instance Eq key => GAlign (OrderedMap key) where galign = galignAlign
+
+-- | Implements a function suitable for use as the definition of 'galign' for 'Align'able functors.
+galignAlign :: Align f => f a -> f b -> Maybe (f (These a b))
+galignAlign a = Just . align a
+
+
+-- Generics
+
+-- | 'GAlign' over unit constructors.
+instance GAlign U1 where
+  galign _ _ = Just U1
+
+-- | 'GAlign' over parameters.
+instance GAlign Par1 where
+  galign (Par1 a) (Par1 b) = Just (Par1 (These a b))
+
+-- | 'GAlign' over non-parameter fields. Only equal values are aligned.
+instance Eq c => GAlign (K1 i c) where
+  galign (K1 a) (K1 b) = guard (a == b) >> Just (K1 b)
+
+-- | 'GAlign' over applications over parameters.
+instance GAlign f => GAlign (Rec1 f) where
+  galign (Rec1 a) (Rec1 b) = Rec1 <$> galign a b
+
+-- | 'GAlign' over metainformation (constructor names, etc).
+instance GAlign f => GAlign (M1 i c f) where
+  galign (M1 a) (M1 b) = M1 <$> galign a b
+
+-- | 'GAlign' over sums. Returns 'Nothing' for disjoint constructors.
+instance (GAlign f, GAlign g) => GAlign (f :+: g) where
+  galign a b = case (a, b) of
+    (L1 a, L1 b) -> L1 <$> galign a b
+    (R1 a, R1 b) -> R1 <$> galign a b
+    _ -> Nothing
+
+-- | 'GAlign' over products.
+instance (GAlign f, GAlign g) => GAlign (f :*: g) where
+  galign (a1 :*: b1) (a2 :*: b2) = (:*:) <$> galign a1 a2 <*> galign b1 b2
+
+-- | 'GAlign' over type compositions.
+instance (Traversable f, Applicative f, GAlign g) => GAlign (f :.: g) where
+  galign (Comp1 a) (Comp1 b) = Comp1 <$> sequenceA (galign <$> a <*> b)

src/Data/OrderedMap.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Data.OrderedMap (
     OrderedMap
   , fromList
@@ -14,12 +15,15 @@ module Data.OrderedMap (
   , difference
   ) where
 
+import Data.Align
+import Data.These
+import GHC.Generics
 import Prologue hiding (toList, empty)
 import Test.QuickCheck
 
 -- | An ordered map of keys and values.
 newtype OrderedMap key value = OrderedMap { toList :: [(key, value)] }
-  deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+  deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
 
 -- | Construct an ordered map from a list of pairs of keys and values.
 fromList :: [(key, value)] -> OrderedMap key value
@@ -33,7 +37,7 @@ infixl 9 !
 
 -- | Look up a value in the map by key, erroring if it doesn't exist.
 (!) :: Eq key => OrderedMap key value -> key -> value
-map ! key = fromMaybe (error "no value found for key") $ Data.OrderedMap.lookup key map
+m ! key = fromMaybe (error "no value found for key") $ Data.OrderedMap.lookup key m
 
 -- | Look up a value in the map by key, returning Nothing if it doesn't exist.
 lookup :: Eq key => key -> OrderedMap key value -> Maybe value
@@ -49,7 +53,7 @@ empty = OrderedMap []
 
 -- | Combine `a` and `b`, picking the values from `a` when keys overlap.
 union :: Eq key => OrderedMap key value -> OrderedMap key value -> OrderedMap key value
-union a b = OrderedMap $ toList a ++ toList (difference b a)
+union a b = OrderedMap $ toList a <> toList (difference b a)
 
 -- | Union a list of ordered maps.
 unions :: Eq key => [OrderedMap key value] -> OrderedMap key value
@@ -75,3 +79,7 @@ instance Eq key => Monoid (OrderedMap key value) where
 instance (Arbitrary key, Arbitrary value) => Arbitrary (OrderedMap key value) where
   arbitrary = fromList <$> arbitrary
   shrink = genericShrink
+
+instance Eq key => Align (OrderedMap key) where
+  nil = fromList []
+  align a b = intersectionWith These a b <> (This <$> difference a b) <> (That <$> difference b a)

src/Data/RandomWalkSimilarity.hs

@@ -3,7 +3,6 @@ module Data.RandomWalkSimilarity where
 import Control.Arrow ((&&&))
 import Control.Monad.Random
 import Control.Monad.State
-import Data.Bifunctor.Join
 import qualified Data.DList as DList
 import Data.Functor.Foldable as Foldable
 import Data.Hashable
@@ -20,35 +19,34 @@ import Test.QuickCheck hiding (Fixed)
 import Test.QuickCheck.Random
 
 -- | Given a function comparing two terms recursively, and a function to compute a Hashable label from an annotation, compute the diff of a pair of lists of terms using a random walk similarity metric, which completes in log-linear time. This implementation is based on the paper [_RWS-Diff—Flexible and Efficient Change Detection in Hierarchical Data_](https://github.com/github/semantic-diff/files/325837/RWS-Diff.Flexible.and.Efficient.Change.Detection.in.Hierarchical.Data.pdf).
-rws :: (Hashable label, Hashable leaf, Eq leaf, Ord annotation) => (Term leaf annotation -> Term leaf annotation -> Maybe (Diff leaf annotation)) -> (annotation -> label) -> [Term leaf annotation] -> [Term leaf annotation] -> [Diff leaf annotation]
+rws :: (Hashable label, Hashable leaf, Eq leaf, Eq annotation) => (Term leaf annotation -> Term leaf annotation -> Maybe (Diff leaf annotation)) -> (annotation -> label) -> [Term leaf annotation] -> [Term leaf annotation] -> [Diff leaf annotation]
 rws compare getLabel as bs
   | null as, null bs = []
   | null as = insert <$> bs
   | null bs = delete <$> as
-  | otherwise = uncurry deleteRemaining . (`runState` fas) $ traverse findNearestNeighbourTo fbs
+  | otherwise = fmap snd . uncurry deleteRemaining . (`runState` (negate 1, fas)) $ traverse findNearestNeighbourTo fbs
   where insert = pure . Insert
         delete = pure . Delete
-        replace = (pure .) . Replace
         (p, q, d) = (2, 2, 15)
-        fas = featurize <$> as
-        fbs = featurize <$> bs
-        kdas = KdTree.build (Vector.toList . fst) fas
-        featurize = featureVector d . pqGrams p q getLabel &&& identity
-        findNearestNeighbourTo kv@(_, v) = do
-          unmapped <- get
-          let (k, _) = KdTree.nearest kdas kv
-          case k `List.lookup` unmapped of
-            Nothing -> pure $! insert v
-            Just found -> do
-              put (List.delete (k, found) unmapped)
-              pure $! fromMaybe (replace found v) (compare found v)
-        deleteRemaining diffs unmapped = foldl' (flip (List.insertBy (comparing firstAnnotation))) diffs (delete . snd <$> unmapped)
+        fas = zipWith featurize [0..] as
+        fbs = zipWith featurize [0..] bs
+        kdas = KdTree.build (Vector.toList . feature) fas
+        featurize index term = UnmappedTerm index (featureVector d (pqGrams p q getLabel term)) term
+        findNearestNeighbourTo kv@(UnmappedTerm _ _ v) = do
+          (previous, unmapped) <- get
+          let (UnmappedTerm i _ _) = KdTree.nearest kdas kv
+          fromMaybe (pure (negate 1, insert v)) $ do
+            found <- find ((== i) . termIndex) unmapped
+            guard (i >= previous)
+            compared <- compare (term found) v
+            pure $! do
+              put (i, List.delete found unmapped)
+              pure (i, compared)
+        deleteRemaining diffs (_, unmapped) = foldl' (flip (List.insertBy (comparing fst))) diffs ((termIndex &&& delete . term) <$> unmapped)
 
--- | Extract the annotation for the before state of a diff node. This is returned in `Maybe` because e.g. an `Insert` patch does not have an annotation for the before state.
-firstAnnotation :: Diff leaf annotation -> Maybe annotation
-firstAnnotation diff = case runFree diff of
-  Free (annotations :< _) -> Just (fst (runJoin annotations))
-  Pure patch -> maybeFst (unPatch $ extract <$> patch)
+-- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index.
+data UnmappedTerm leaf annotation = UnmappedTerm { termIndex :: {-# UNPACK #-} !Int, feature :: !(Vector.Vector Double), term :: !(Term leaf annotation) }
+  deriving Eq
 
 -- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree.
 data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }

src/Interpreter.hs

@@ -3,6 +3,7 @@ module Interpreter (Comparable, DiffConstructor, diffTerms) where
 import Algorithm
 import qualified Category as C
 import Data.Align
+import Data.Align.Generic
 import Data.Functor.Foldable
 import Data.Functor.Both hiding (fst, snd)
 import Data.Hashable
@@ -34,16 +35,14 @@ diffTerms construct comparable cost a b = fromMaybe (pure $ Replace a b) $ const
 
 -- | Constructs an algorithm and runs it
 constructAndRun :: (Show leaf, Show (Record fields), Eq leaf, Hashable leaf, Ord (Record fields), HasField fields C.Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields))
-constructAndRun _ comparable _ a b | not $ comparable a b = Nothing
-
-constructAndRun construct _ _ a b | (() <$ a) == (() <$ b) = hylo construct runCofree <$> zipTerms a b
-
-constructAndRun construct comparable cost t1 t2 =
-  run construct comparable cost $ algorithm a b where
-    algorithm (Indexed a') (Indexed b') = free . Free $ ByIndex a' b' (annotate . Indexed)
-    algorithm (Keyed a') (Keyed b') = free . Free $ ByKey a' b' (annotate . Keyed)
+constructAndRun construct comparable cost t1 t2
+  | not $ comparable t1 t2 = Nothing
+  | (() <$ t1) == (() <$ t2) = hylo construct runCofree <$> zipTerms t1 t2
+  | otherwise = run construct comparable cost $ algorithm a b where
+    algorithm (Indexed a') (Indexed b') = wrap $! ByIndex a' b' (annotate . Indexed)
+    algorithm (Keyed a') (Keyed b') = wrap $! ByKey a' b' (annotate . Keyed)
     algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b'
-    algorithm a' b' = free . Free $ Recursive (cofree (annotation1 :< a')) (cofree (annotation2 :< b')) pure
+    algorithm a' b' = wrap $! Recursive (cofree (annotation1 :< a')) (cofree (annotation2 :< b')) pure
     (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2)
     annotate = pure . construct . (both annotation1 annotation2 :<)
 
@@ -55,36 +54,8 @@ run construct comparable cost algorithm = case runFree algorithm of
     (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2)
     annotate = construct . (both annotation1 annotation2 :<)
     diffTerms' = diffTerms construct comparable cost
-
-    recur (Indexed a') (Indexed b') = annotate . Indexed $ alignWith diffThese a' b'
-    recur (Fixed a') (Fixed b') = annotate . Fixed $ alignWith diffThese a' b'
-    recur (Keyed a') (Keyed b') | Map.keys a' == bKeys = annotate . Keyed . Map.fromList . fmap repack $ bKeys where
-      bKeys = Map.keys b'
-      repack key = (key, interpretInBoth key a' b')
-      interpretInBoth key x y = diffTerms' (x ! key) (y ! key)
-    recur (FunctionCall a' as') (FunctionCall b' bs') | length as' == length bs' = annotate $ FunctionCall (diffTerms' a' b') (zipWith diffTerms' as' bs')
-    recur (Function a' as' aExprs') (Function b' bs' bExprs') = annotate $ Function (liftA2 diffTerms' a' b') (liftA2 diffTerms' as' bs') (diffTerms' aExprs' bExprs')
-    recur (Assignment a' as') (Assignment b' bs') = annotate $ Assignment (diffTerms' a' b') (diffTerms' as' bs')
-    recur (MathAssignment a' as') (MathAssignment b' bs') = annotate $ MathAssignment (diffTerms' a' b') (diffTerms' as' bs')
-    recur (MemberAccess a' as') (MemberAccess b' bs') = annotate $ MemberAccess (diffTerms' a' b') (diffTerms' as' bs')
-    recur (SubscriptAccess a' as') (SubscriptAccess b' bs') = annotate $ SubscriptAccess (diffTerms' a' b') (diffTerms' as' bs')
-    recur (MethodCall a' as' aParams') (MethodCall b' bs' bParams') = annotate $ MethodCall (diffTerms' a' b') (diffTerms' as' bs') (diffTerms' aParams' bParams')
-    recur (Ternary aCondition' aCases') (Ternary bCondition' bCases') = annotate $ Ternary (diffTerms' aCondition' bCondition') (alignWith diffThese aCases' bCases')
-    recur (Args as') (Args bs') = annotate . Args $ alignWith diffThese as' bs'
-    recur (VarDecl a') (VarDecl b') = annotate . VarDecl $ diffTerms' a' b'
-    recur (VarAssignment a' as') (VarAssignment b' bs') = annotate $ VarAssignment (diffTerms' a' b') (diffTerms' as' bs')
-    recur (Operator a') (Operator b') = annotate $ Operator (alignWith diffThese a' b')
-    recur (Switch a' as') (Switch b' bs') = annotate $ Switch (diffTerms' a' b') (alignWith (these (pure . Delete) (pure . Insert) diffTerms') as' bs')
-    recur (Case a' as') (Case b' bs') = annotate $ Case (diffTerms' a' b') (diffTerms' as' bs')
-    recur (Object as') (Object bs') = annotate $ Object (alignWith diffThese as' bs')
-    recur (Pair a1 a2) (Pair b1 b2) = annotate $ Pair (diffTerms' a1 b1) (diffTerms' a2 b2)
-    recur (Commented a1 a2) (Commented b1 b2) = annotate $ Commented (alignWith diffThese a1 b1) (diffTerms' <$> a2 <*> b2)
-    recur (Comment _) (Comment _) = pure $ Replace (cofree (annotation1 :< a)) (cofree (annotation2 :< b))
-    recur (Leaf _) (Leaf _) = pure $ Replace (cofree (annotation1 :< a)) (cofree (annotation2 :< b))
-    recur _ _ = pure $ Replace (cofree (annotation1 :< a)) (cofree (annotation2 :< b))
-
+    recur a b = maybe (pure (Replace t1 t2)) (annotate . fmap diffThese) (galign a b)
     diffThese = these (pure . Delete) (pure . Insert) (diffTerms construct comparable cost)
-
   Free (ByKey a b f) -> run construct comparable cost $ f byKey where
     byKey = Map.fromList $ toKeyValue <$> List.union aKeys bKeys
     toKeyValue key | key `List.elem` deleted = (key, pure . Delete $ a ! key)

src/Patch.hs

@@ -16,7 +16,7 @@ data Patch a
   = Replace a a
   | Insert a
   | Delete a
-  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
+  deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
 
 -- | Return the item from the after side of the patch.
 after :: Patch a -> Maybe a

src/SES.hs

@@ -1,8 +1,9 @@
 module SES where
 
-import Prologue
-import Patch
 import qualified Data.Map as Map
+import Patch
+import Prologue
+
 
 -- | Edit constructor for two terms, if comparable. Otherwise returns Nothing.
 type Compare term edit = term -> term -> Maybe edit
@@ -18,9 +19,6 @@ ses diffTerms cost as bs = fst <$> evalState diffState Map.empty where
 -- | Find the shortest edit script between two terms at a given vertex in the edit graph.
 diffAt :: Applicative edit => Compare term (edit (Patch term)) -> Cost (edit (Patch term)) -> (Integer, Integer) -> [term] -> [term] -> State (Map.Map (Integer, Integer) [(edit (Patch term), Integer)]) [(edit (Patch term), Integer)]
 diffAt diffTerms cost (i, j) as bs
-  | null as, null bs = pure []
-  | null as = pure $ foldr insert [] bs
-  | null bs = pure $ foldr delete [] as
   | (a : as) <- as, (b : bs) <- bs = do
   cachedDiffs <- get
   case Map.lookup (i, j) cachedDiffs of
@@ -28,7 +26,7 @@ diffAt diffTerms cost (i, j) as bs
     Nothing -> do
       down <- recur (i, succ j) as (b : bs)
       right <- recur (succ i, j) (a : as) bs
-      nomination <- fmap best $ case diffTerms a b of
+      nomination <- best <$> case diffTerms a b of
         Just diff -> do
           diagonal <- recur (succ i, succ j) as bs
           pure [ delete a down, insert b right, consWithCost cost diff diagonal ]
@@ -36,6 +34,9 @@ diffAt diffTerms cost (i, j) as bs
       cachedDiffs' <- get
       put $ Map.insert (i, j) nomination cachedDiffs'
       pure nomination
+  | null as = pure $ foldr insert [] bs
+  | null bs = pure $ foldr delete [] as
+  | otherwise = pure []
   where
     delete = consWithCost cost . pure . Delete
     insert = consWithCost cost . pure . Insert
@@ -44,6 +45,7 @@ diffAt diffTerms cost (i, j) as bs
     best = minimumBy (comparing costOf)
     recur = diffAt diffTerms cost
 
+
 -- | Prepend an edit script and the cumulative cost onto the edit script.
 consWithCost :: Cost edit -> edit -> [(edit, Integer)] -> [(edit, Integer)]
 consWithCost cost edit rest = (edit, cost edit + maybe 0 snd (fst <$> uncons rest)) : rest

src/Syntax.hs

@@ -3,6 +3,7 @@ module Syntax where
 import Prologue
 import Data.OrderedMap as Map
 import Data.Text.Arbitrary ()
+import GHC.Generics
 import qualified Data.Text as T
 import Test.QuickCheck hiding (Fixed)
 
@@ -53,7 +54,7 @@ data Syntax
   | Pair f f
   | Comment a
   | Commented [f] (Maybe f)
-  deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable)
+  deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
 
 -- Instances
 

src/Term.hs

@@ -1,11 +1,12 @@
-{-# LANGUAGE TypeFamilies, TypeSynonymInstances, Unsafe #-}
+{-# LANGUAGE RankNTypes, TypeFamilies, TypeSynonymInstances, Unsafe #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Term where
 
 import Prologue
+import Data.Align.Generic
 import Data.Functor.Foldable as Foldable
 import Data.Functor.Both
-import Data.OrderedMap hiding (size)
+import Data.These
 import Syntax
 import Unsafe
 
@@ -19,38 +20,24 @@ instance Functor f => Foldable.Unfoldable (Cofree f a) where embed = cofree
 
 -- | Zip two terms by combining their annotations into a pair of annotations.
 -- | If the structure of the two terms don't match, then Nothing will be returned.
+
 zipTerms :: (Eq a, Eq annotation) => Term a annotation -> Term a annotation -> Maybe (Term a (Both annotation))
-zipTerms t1 t2 = annotate (zipUnwrap a b)
-  where
-    (annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2)
-    annotate = fmap (cofree . (both annotation1 annotation2 :<))
-    zipUnwrap (Leaf _) (Leaf b') = Just $ Leaf b'
-    zipUnwrap (Comment _) (Comment b) = Just $ Comment b
-    zipUnwrap (Indexed a') (Indexed b') = Indexed <$> zipWithM zipTerms a' b'
-    zipUnwrap (Fixed a') (Fixed b') = Fixed <$> zipWithM zipTerms a' b'
-    zipUnwrap (Keyed a') (Keyed b') | keys a' == keys b' = Just . Keyed . fromList . catMaybes $ zipUnwrapMaps a' b' <$> keys a'
-    zipUnwrap (FunctionCall idA' a') (FunctionCall idB' b') = FunctionCall <$> zipTerms idA' idB' <*> zipWithM zipTerms a' b'
-    zipUnwrap (Function idA' paramsA' exprsA') (Function idB' paramsB' exprsB') = case (zipTerms exprsA' exprsB') of
-      Just exprs' ->  Just (Function (join $ liftA2 zipTerms idA' idB') (join $ liftA2 zipTerms paramsA' paramsB') exprs')
-      _ -> Nothing
-    zipUnwrap (Case eA' bodyA') (Case eB' bodyB') = Case <$> zipTerms eA' eB' <*> zipTerms bodyA' bodyB'
-    zipUnwrap (Switch a' as') (Switch b' bs') = Switch <$> (zipTerms a' b') <*> zipWithM zipTerms as' bs'
-    zipUnwrap (MethodCall iA mA paramsA) (MethodCall iB mB paramsB) = MethodCall <$> zipTerms iA iB <*> zipTerms mA mB <*> zipTerms paramsA paramsB
-    zipUnwrap (Args a1) (Args b1) = Args <$> (zipWithM zipTerms a1 b1)
-    zipUnwrap (MemberAccess a1 a2) (MemberAccess b1 b2) = MemberAccess <$> zipTerms a1 b1 <*> zipTerms a2 b2
-    zipUnwrap (MathAssignment a1 a2) (MathAssignment b1 b2) = MathAssignment <$> zipTerms a1 b1 <*> zipTerms a2 b2
-    zipUnwrap (Assignment a1 a2) (Assignment b1 b2) = Assignment <$> zipTerms a1 b1 <*> zipTerms a2 b2
-    zipUnwrap (Ternary a1 a2) (Ternary b1 b2) = Ternary <$> zipTerms a1 b1 <*> (zipWithM zipTerms a2 b2)
-    zipUnwrap (Object as') (Object bs') | as' == bs' = Object <$> zipWithM zipTerms as' bs'
-    zipUnwrap (Operator as) (Operator bs) = Operator <$> zipWithM zipTerms as bs
-    zipUnwrap (VarDecl a) (VarDecl b) = VarDecl <$> zipTerms a b
-    zipUnwrap (VarAssignment a1 a2) (VarAssignment b1 b2) = VarAssignment <$> zipTerms a1 b1 <*> zipTerms a2 b2
-    zipUnwrap (SubscriptAccess a1 a2) (SubscriptAccess b1 b2) = SubscriptAccess <$> zipTerms a1 b1 <*> zipTerms a2 b2
-    zipUnwrap (Pair a1' a2') (Pair b1' b2') = Pair <$> zipTerms a1' b1' <*> zipTerms a2' b2'
-    zipUnwrap (Commented cs1 a) (Commented cs2 b) = Commented <$> zipWithM zipTerms cs1 cs2 <*> (zipTerms <$> a <*> b)
-    zipUnwrapMaps a' b' key = (,) key <$> zipTerms (a' ! key) (b' ! key)
+zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2))
+  where go (a :< s) = cofree . (a :<) <$> sequenceA s
 
 -- | Return the node count of a term.
 termSize :: Term a annotation -> Integer
 termSize = cata size where
   size (_ :< syntax) = 1 + sum syntax
+
+-- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms.
+alignCofreeWith :: Functor f
+  => (forall a b. f a -> f b -> Maybe (f (These a b))) -- ^ A function comparing a pair of structures, returning `Just` the combined structure if they are comparable (e.g. if they have the same constructor), and `Nothing` otherwise. The 'Data.Align.Generic.galign' function is usually what you want here.
+  -> (These (Cofree f a) (Cofree f b) -> contrasted) -- ^ A function mapping a 'These' of incomparable terms into 'Pure' values in the resulting tree.
+  -> (a -> b -> combined) -- ^ A function mapping the input terms’ annotations into annotations in the 'Free' values in the resulting tree.
+  -> These (Cofree f a) (Cofree f b) -- ^ The input terms.
+  -> Free (CofreeF f combined) contrasted
+alignCofreeWith compare contrast combine = go
+  where go terms = fromMaybe (pure (contrast terms)) $ case terms of
+          These t1 t2 -> wrap . (combine (extract t1) (extract t2) :<) . fmap go <$> compare (unwrap t1) (unwrap t2)
+          _ -> Nothing

test/Data/RandomWalkSimilarity/Spec.hs

@@ -3,7 +3,6 @@ module Data.RandomWalkSimilarity.Spec where
 import Category
 import Data.DList as DList hiding (toList)
 import Data.RandomWalkSimilarity
-import qualified Data.Set as Set
 import Diff
 import Patch
 import Prologue
@@ -33,7 +32,5 @@ spec = parallel $ do
       \ (as, bs) -> let tas = toTerm <$> as
                         tbs = toTerm <$> bs
                         diff = free (Free (pure Program :< Indexed (rws compare identity tas tbs :: [Diff Text Category]))) in
-        (childrenOf <$> beforeTerm diff, childrenOf <$> afterTerm diff) `shouldBe` (Just (Set.fromList tas), Just (Set.fromList tbs))
+        (beforeTerm diff, afterTerm diff) `shouldBe` (Just (cofree (Program :< Indexed tas)), Just (cofree (Program :< Indexed tbs)))
 
-childrenOf :: (Ord leaf, Ord annotation) => Term leaf annotation -> Set.Set (Term leaf annotation)
-childrenOf = Set.fromList . toList . unwrap

weekly/2016-07-12.md

@@ -0,0 +1,29 @@
+# July 12th, 2016 weekly
+
+## What went well?
+
+@joshvera: Glad to see objects working, and the test harness was helpful for that.
+
+@robrix: RWS work went well, specifically about ordering. Also confirming that RWS does not conflict with moves, although we do not support moves yet. Also generics with zipping turned out well!
+
+@rewinfrey: The move went well, more or less.
+
+## What went less well?
+
+@joshvera: Was sick and would have liked to contribute to test harness earlier.
+
+@robrix: Scrap your boilerplate style of generic programming in Haskell is tough.
+
+@rewinfrey: Adding test cases manually is tough. Want to find a way to automate that process.
+
+## What did you learn?
+
+@joshvera: Learned a lot about RWS, and generics in Haskell.
+
+@robrix: Learned about natural transformations. Understood RWS ordering problem. How to metaprogram in Haskell without headaches! Wrote a catamorphism that annotates every element in the structure with the result of the fold up to that element.
+
+@rewinfrey: Learned how to install curtains, and visiting Ikea is ideal on the 4th of July.
+
+## Anything else?
+
+@robrix: Reminder about Q3 goals, will be the focus of 1:1's for the next couple weeks. Checkin with how weekly format is going (@joshvera & @rewinfrey no complaints). Also see everyone at Summit!