Merge pull request #614 from github/extensible-annotations

Extensible annotations

semantic-diff.cabal

@@ -19,6 +19,7 @@ library
                      , Data.Bifunctor.Join.Arbitrary
                      , Data.Functor.Both
                      , Data.OrderedMap
+                     , Data.Record
                      , Data.These.Arbitrary
                      , Diff
                      , Diff.Arbitrary

src/Alignment.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables #-}
 module Alignment
 ( hasChanges
 , numberedRows
@@ -18,6 +18,7 @@ import Data.Functor.Foldable (hylo)
 import Data.List (partition)
 import Data.Maybe (fromJust)
 import qualified Data.OrderedMap as Map
+import Data.Record
 import Data.These
 import Diff
 import Info
@@ -39,15 +40,15 @@ numberedRows = countUp (both 1 1)
         nextLineNumbers from row = modifyJoin (fromThese identity identity) (succ <$ row) <*> from
 
 -- | Determine whether a line contains any patches.
-hasChanges :: SplitDiff leaf Info -> Bool
+hasChanges :: SplitDiff leaf annotation -> Bool
 hasChanges = or . (True <$)
 
 -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side.
-alignDiff :: Show leaf => Both (Source Char) -> Diff leaf Info -> [Join These (SplitDiff leaf Info)]
+alignDiff :: (Show leaf, Show (Record fields), HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [Join These (SplitDiff leaf (Record fields))]
 alignDiff sources diff = iter (alignSyntax (runBothWith ((Join .) . These)) (free . Free) getRange sources) (alignPatch sources <$> diff)
 
 -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff.
-alignPatch :: forall leaf. Show leaf => Both (Source Char) -> Patch (Term leaf Info) -> [Join These (SplitDiff leaf Info)]
+alignPatch :: forall fields leaf. (Show leaf, Show (Record fields), HasField fields Range) => Both (Source Char) -> Patch (Term leaf (Record fields)) -> [Join These (SplitDiff leaf (Record fields))]
 alignPatch sources patch = case patch of
   Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term
   Insert term -> fmap (pure . SplitInsert) <$> alignSyntax' that (snd sources) term
@@ -55,13 +56,13 @@ alignPatch sources patch = case patch of
     (alignSyntax' this (fst sources) term1)
     (alignSyntax' that (snd sources) term2)
   where getRange = characterRange . extract
-        alignSyntax' :: (forall a. Identity a -> Join These a) -> Source Char -> Term leaf Info -> [Join These (Term leaf Info)]
+        alignSyntax' :: (forall a. Identity a -> Join These a) -> Source Char -> Term leaf (Record fields) -> [Join These (Term leaf (Record fields))]
         alignSyntax' side source term = hylo (alignSyntax side cofree getRange (Identity source)) runCofree (Identity <$> term)
         this = Join . This . runIdentity
         that = Join . That . runIdentity
 
 -- | 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, Show term) => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) Info term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f Info) [Join These term] -> [Join These term]
+alignSyntax :: (Applicative f, Show term, 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 (,) []) <$> sequenceL lineRanges
   Indexed children -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges
@@ -69,7 +70,7 @@ alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = case syntax
   Keyed children -> catMaybes $ wrapInBranch (Keyed . Map.fromList) <$> alignBranch (getRange . Prologue.snd) (Map.toList children >>= pairWithKey) bothRanges
   where bothRanges = modifyJoin (fromThese [] []) lineRanges
         lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources
-        wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (info { characterRange = range } :< constructor children)) <$> infos)
+        wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (setCharacterRange info range :< constructor children)) <$> infos)
         pairWithKey (key, values) = fmap ((,) key) <$> values
 
 -- | Given a function to get the range, a list of already-aligned children, and the lists of ranges spanned by a branch, return the aligned lines.
@@ -86,7 +87,7 @@ alignBranch getRange children ranges = case intersectingChildren of
   _ -> case intersectionsWithHeadRanges <$> listToMaybe symmetricalChildren of
     -- At least one child intersects on both sides, so align symmetrically.
     Just (True, True) -> let (line, remaining) = lineAndRemaining intersectingChildren (Just headRanges) in
-      line $ alignBranch getRange (remaining ++ nonIntersectingChildren) (drop 1 <$> ranges)
+      line $ alignBranch getRange (remaining <> nonIntersectingChildren) (drop 1 <$> ranges)
     -- A symmetrical child intersects on the right, so align asymmetrically on the left.
     Just (False, True) -> alignAsymmetrically leftRange first
     -- A symmetrical child intersects on the left, so align asymmetrically on the right.
@@ -101,7 +102,7 @@ alignBranch getRange children ranges = case intersectingChildren of
         Just headRanges = sequenceL (listToMaybe <$> Join (runBothWith These ranges))
         (leftRange, rightRange) = splitThese headRanges
         alignAsymmetrically range advanceBy = let (line, remaining) = lineAndRemaining asymmetricalChildren range in
-          line $ alignBranch getRange (remaining ++ symmetricalChildren ++ nonIntersectingChildren) (modifyJoin (advanceBy (drop 1)) ranges)
+          line $ alignBranch getRange (remaining <> symmetricalChildren <> nonIntersectingChildren) (modifyJoin (advanceBy (drop 1)) ranges)
         lineAndRemaining _ Nothing = (identity, [])
         lineAndRemaining children (Just ranges) = let (intersections, remaining) = alignChildren getRange children ranges in
           ((:) $ (,) <$> ranges `applyToBoth` (sortBy (compare `on` getRange) <$> intersections), remaining)

src/Data/Record.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds, FlexibleContexts, GADTs, KindSignatures, MultiParamTypeClasses, TypeOperators #-}
+module Data.Record where
+
+import Prologue
+
+-- | A type-safe, extensible record structure.
+-- |
+-- | This is heavily inspired by Aaron Levin’s [Extensible Effects in the van Laarhoven Free Monad](http://aaronlevin.ca/post/136494428283/extensible-effects-in-the-van-laarhoven-free-monad).
+data Record :: [*] -> * where
+  RNil :: Record '[]
+  RCons :: h -> Record t -> Record (h ': t)
+
+infixr 0 .:
+
+-- | Infix synonym for `RCons`: `a .: b .: RNil == RCons a (RCons b RNil)`.
+(.:) :: h -> Record t -> Record (h ': t)
+(.:) = RCons
+
+
+-- Classes
+
+-- | HasField enables indexing a Record by (phantom) type tags.
+class HasField (fields :: [*]) (field :: *) where
+  getField :: Record fields -> field
+  setField :: Record fields -> field -> Record fields
+
+
+-- Instances
+
+-- OVERLAPPABLE is required for the HasField instances so that we can handle the two cases: either the head of the non-empty h-list is the requested field, or it isn’t. The third possible case (the h-list is empty) is rejected at compile-time.
+
+instance {-# OVERLAPPABLE #-} HasField fields field => HasField (notIt ': fields) field where
+  getField (RCons _ t) = getField t
+  setField (RCons h t) f = RCons h (setField t f)
+
+instance {-# OVERLAPPABLE #-} HasField (field ': fields) field where
+  getField (RCons h _) = h
+  setField (RCons _ t) f = RCons f t
+
+
+instance (Show h, Show (Record t)) => Show (Record (h ': t)) where
+  showsPrec n (RCons h t) = showsPrec n h . (" : " <>) . showsPrec n t
+
+instance Show (Record '[]) where
+  showsPrec _ RNil = ("'[]" <>)
+
+
+instance (Eq h, Eq (Record t)) => Eq (Record (h ': t)) where
+  RCons h1 t1 == RCons h2 t2 = h1 == h2 && t1 == t2
+
+instance Eq (Record '[]) where
+  _ == _ = True

src/Diffing.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE FlexibleContexts #-}
 module Diffing where
 
 import Prologue hiding (fst, snd)
 import qualified Data.ByteString.Char8 as B1
 import Data.Functor.Both
 import Data.Functor.Foldable
+import Data.Record
 import qualified Data.Text as T
 import qualified Data.Text.ICU.Detect as Detect
 import qualified Data.Text.ICU.Convert as Convert
@@ -39,8 +41,8 @@ lineByLineParser input = pure . cofree . root $ case foldl' annotateLeaves ([],
   where
     lines = actualLines input
     root children = let size = 1 + fromIntegral (length children) in
-      Info (Range 0 $ length input) (Other "program") size size :< Indexed children
+      ((Range 0 $ length input) .: Other "program" .: size .: Cost (unSize size) .: RNil) :< Indexed children
-    leaf charIndex line = Info (Range charIndex $ charIndex + T.length line) (Other "program") 1 1 :< Leaf line
+    leaf charIndex line = ((Range charIndex $ charIndex + T.length line) .: Other "program" .: 1 .: 1 .: RNil) :< Leaf line
     annotateLeaves (accum, charIndex) line =
       (accum ++ [ leaf charIndex (toText line) ]
       , charIndex + length line)
@@ -55,13 +57,13 @@ breakDownLeavesByWord :: Source Char -> Term T.Text Info -> Term T.Text Info
 breakDownLeavesByWord source = cata replaceIn
   where
     replaceIn :: TermF T.Text Info (Term T.Text Info) -> Term T.Text Info
-    replaceIn (info :< syntax) = let size' = 1 + sum (size . extract <$> syntax') in cofree $ info { size = size', cost = size' } :< syntax'
+    replaceIn (info :< syntax) = let size' = 1 + sum (size . extract <$> syntax') in cofree $ setCost (setSize info size') (Cost (unSize size')) :< syntax'
       where syntax' = case (ranges, syntax) of
               (_:_:_, Leaf _) -> Indexed (makeLeaf info <$> ranges)
               _ -> syntax
             ranges = rangesAndWordsInSource (characterRange info)
     rangesAndWordsInSource range = rangesAndWordsFrom (start range) (toString $ slice range source)
-    makeLeaf info (range, substring) = cofree $ info { characterRange = range } :< Leaf (T.pack substring)
+    makeLeaf info (range, substring) = cofree $ setCharacterRange info range :< Leaf (T.pack substring)
 
 -- | Transcode a file to a unicode source.
 transcode :: B1.ByteString -> IO (Source Char)
@@ -95,7 +97,6 @@ diffFiles parser renderer sourceBlobs = do
   pure $! renderer textDiff sourceBlobs
   where construct :: CofreeF (Syntax Text) (Both Info) (Diff Text Info) -> Diff Text Info
         construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax))
-        setCost info cost = info { cost = cost }
         sumCost = fmap getSum . foldMap (fmap Sum . getCost)
         getCost diff = case runFree diff of
           Free (info :< _) -> cost <$> info
@@ -104,6 +105,6 @@ diffFiles parser renderer sourceBlobs = do
 
 -- | The sum of the node count of the diff’s patches.
 diffCostWithCachedTermSizes :: Diff a Info -> Integer
-diffCostWithCachedTermSizes diff = case runFree diff of
+diffCostWithCachedTermSizes diff = unCost $ case runFree diff of
   Free (info :< _) -> sum (cost <$> info)
   Pure patch -> sum (cost . extract <$> patch)

src/Info.hs

@@ -1,10 +1,40 @@
+{-# LANGUAGE DataKinds, FlexibleContexts, GeneralizedNewtypeDeriving #-}
 module Info where
 
+import Data.Record
 import Prologue
 import Category
 import Range
 
--- | An annotation for a source file, including the source range and semantic
+newtype Size = Size { unSize :: Integer }
--- | categories.
+  deriving (Eq, Num, Show)
-data Info = Info { characterRange :: !Range, category :: !Category, size :: !Integer, cost :: !Integer }
+newtype Cost = Cost { unCost :: Integer }
-  deriving (Eq, Show)
+  deriving (Eq, Num, Show)
+
+type InfoFields = '[ Range, Category, Size, Cost ]
+
+type Info = Record InfoFields
+
+characterRange :: HasField fields Range => Record fields -> Range
+characterRange = getField
+
+setCharacterRange :: HasField fields Range => Record fields -> Range -> Record fields
+setCharacterRange = setField
+
+category :: HasField fields Category => Record fields -> Category
+category = getField
+
+setCategory :: HasField fields Category => Record fields -> Category -> Record fields
+setCategory = setField
+
+size :: HasField fields Size => Record fields -> Size
+size = getField
+
+setSize :: HasField fields Size => Record fields -> Size -> Record fields
+setSize = setField
+
+cost :: HasField fields Cost => Record fields -> Cost
+cost = getField
+
+setCost :: HasField fields Cost => Record fields -> Cost -> Record fields
+setCost = setField

src/Parser.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 module Parser where
 
 import Prologue hiding (Constructor)

src/Renderer/JSON.hs

@@ -66,7 +66,7 @@ lineFields n term range = [ "number" .= n
                           ]
 
 termFields :: (ToJSON recur, KeyValue kv) => Info -> Syntax leaf recur -> [kv]
-termFields Info{..} syntax = "range" .= characterRange : "category" .= category : case syntax of
+termFields info syntax = "range" .= characterRange info : "category" .= category info : case syntax of
   Leaf _ -> []
   Indexed c -> childrenFields c
   Fixed c -> childrenFields c

src/Renderer/Split.hs

@@ -93,11 +93,11 @@ split diff blobs = TL.toStrict . renderHtml
 newtype Renderable a = Renderable a
 
 instance ToMarkup f => ToMarkup (Renderable (Source Char, Info, Syntax a (f, Range))) where
-  toMarkup (Renderable (source, Info {..}, syntax)) = (! A.data_ (stringValue (show size))) . classifyMarkup category $ case syntax of
+  toMarkup (Renderable (source, info, syntax)) = (! A.data_ (stringValue (show (unSize (size info))))) . classifyMarkup (category info) $ case syntax of
-    Leaf _ -> span . string . toString $ slice characterRange source
+    Leaf _ -> span . string . toString $ slice (characterRange info) source
-    Indexed children -> ul . mconcat $ wrapIn li <$> contentElements source characterRange children
+    Indexed children -> ul . mconcat $ wrapIn li <$> contentElements source (characterRange info) children
-    Fixed children -> ul . mconcat $ wrapIn li <$> contentElements source characterRange children
+    Fixed children -> ul . mconcat $ wrapIn li <$> contentElements source (characterRange info) children
-    Keyed children -> dl . mconcat $ wrapIn dd <$> contentElements source characterRange children
+    Keyed children -> dl . mconcat $ wrapIn dd <$> contentElements source (characterRange info) children
 
 contentElements :: (Foldable t, ToMarkup f) => Source Char -> Range -> t (f, Range) -> [Markup]
 contentElements source range children = let (elements, next) = foldr' (markupForContextAndChild source) ([], end range) children in
@@ -114,13 +114,13 @@ wrapIn _ l@Blaze.Comment{} = l
 wrapIn f p = f p
 
 instance ToMarkup (Renderable (Source Char, Term a Info)) where
-  toMarkup (Renderable (source, term)) = Prologue.fst $ cata (\ (info@(Info{..}) :< syntax) -> (toMarkup $ Renderable (source, info, syntax), characterRange)) term
+  toMarkup (Renderable (source, term)) = Prologue.fst $ cata (\ (info :< syntax) -> (toMarkup $ Renderable (source, info, syntax), characterRange info)) term
 
 instance ToMarkup (Renderable (Source Char, SplitDiff a Info)) where
-  toMarkup (Renderable (source, diff)) = Prologue.fst $ iter (\ (info@(Info{..}) :< syntax) -> (toMarkup $ Renderable (source, info, syntax), characterRange)) $ toMarkupAndRange <$> diff
+  toMarkup (Renderable (source, diff)) = Prologue.fst $ iter (\ (info :< syntax) -> (toMarkup $ Renderable (source, info, syntax), characterRange info)) $ toMarkupAndRange <$> diff
     where toMarkupAndRange :: SplitPatch (Term a Info) -> (Markup, Range)
-          toMarkupAndRange patch = let term@(Info{..} :< _) = runCofree $ getSplitTerm patch in
+          toMarkupAndRange patch = let term@(info :< _) = runCofree $ getSplitTerm patch in
-            ((div ! A.class_ (splitPatchToClassName patch) ! A.data_ (stringValue (show size))) . toMarkup $ Renderable (source, cofree term), characterRange)
+            ((div ! A.class_ (splitPatchToClassName patch) ! A.data_ (stringValue (show (unSize (size info))))) . toMarkup $ Renderable (source, cofree term), characterRange info)
 
 instance ToMarkup a => ToMarkup (Renderable (Bool, Int, a)) where
   toMarkup (Renderable (hasChanges, num, line)) =

src/SplitDiff.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE FlexibleContexts #-}
 module SplitDiff where
 
+import Data.Record
 import Info
 import Range
 import Prologue
@@ -17,7 +19,7 @@ getSplitTerm (SplitDelete a) = a
 getSplitTerm (SplitReplace a) = a
 
 -- | Get the range of a SplitDiff.
-getRange :: SplitDiff leaf Info -> Range
+getRange :: HasField fields Range => SplitDiff leaf (Record fields) -> Range
 getRange diff = characterRange $ case runFree diff of
   Free annotated -> headF annotated
   Pure patch -> extract (getSplitTerm patch)

src/TreeSitter.hs

@@ -1,6 +1,7 @@
 module TreeSitter where
 
 import Prologue hiding (Constructor)
+import Data.Record
 import Data.String
 import Category
 import Info
@@ -61,7 +62,7 @@ documentToTerm language document contents = alloca $ \ root -> do
           range <- pure $! Range { start = fromIntegral $ ts_node_p_start_char node, end = fromIntegral $ ts_node_p_end_char node }
 
           let size' = 1 + sum (size . extract <$> children)
-          let info = Info range (categoriesForLanguage language name) size' size'
+          let info = range .: (categoriesForLanguage language name) .: size' .: Cost (unSize size') .: RNil
           pure $! termConstructor contents info children
         getChild node n out = do
           _ <- ts_node_p_named_child node n out

test/AlignmentSpec.hs

@@ -11,6 +11,7 @@ import Data.Bifunctor.Join.Arbitrary ()
 import Data.Functor.Both as Both
 import Data.List (nub)
 import Data.Monoid
+import Data.Record
 import Data.String
 import Data.Text.Arbitrary ()
 import Data.These
@@ -258,7 +259,7 @@ align :: Both (Source.Source Char) -> ConstructibleFree (Patch (Term String Info
 align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
 
 info :: Int -> Int -> Info
-info start end = Info (Range start end) StringLiteral 0 0
+info start end = Range start end .: StringLiteral .: 0 .: 0 .: RNil
 
 prettyDiff :: Both (Source.Source Char) -> [Join These (ConstructibleFree (SplitPatch (Term String Info)) Info)] -> PrettyDiff (SplitDiff String Info)
 prettyDiff sources = PrettyDiff sources . fmap (fmap ((getRange &&& identity) . deconstruct))

test/DiffSummarySpec.hs

@@ -1,6 +1,7 @@
 module DiffSummarySpec where
 
 import Prologue
+import Data.Record
 import Data.String
 import Test.Hspec
 import Diff
@@ -12,10 +13,10 @@ import Category
 import DiffSummary
 
 arrayInfo :: Info
-arrayInfo = Info (rangeAt 0) ArrayLiteral 2 0
+arrayInfo = rangeAt 0 .: ArrayLiteral .: 2 .: 0 .: RNil
 
 literalInfo :: Info
-literalInfo = Info (rangeAt 1) StringLiteral 1 0
+literalInfo = rangeAt 1 .: StringLiteral .: 1 .: 0 .: RNil
 
 testDiff :: Diff String Info
 testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ])

test/InterpreterSpec.hs

@@ -2,6 +2,7 @@ module InterpreterSpec where
 
 import Prologue
 import Diff
+import Data.Record
 import qualified Interpreter as I
 import Range
 import Syntax
@@ -14,8 +15,8 @@ spec :: Spec
 spec = parallel $
   describe "interpret" $
     it "returns a replacement when comparing two unicode equivalent terms" $
-      I.diffTerms (free . Free) ((==) `on` extract) diffCost (cofree (Info range StringLiteral 0 0 :< Leaf "t\776")) (cofree (Info range2 StringLiteral 0 0 :< Leaf "\7831")) `shouldBe`
+      I.diffTerms (free . Free) ((==) `on` extract) diffCost (cofree ((range .: StringLiteral .: 0 .: 0 .: RNil) :< Leaf "t\776")) (cofree ((range2 .: StringLiteral .: 0 .: 0 .: RNil) :< Leaf "\7831")) `shouldBe`
-      free (Pure (Replace (cofree (Info range StringLiteral 0 0 :< Leaf "t\776")) (cofree (Info range2 StringLiteral 0 0 :< Leaf "\7831"))))
+      free (Pure (Replace (cofree ((range .: StringLiteral .: 0 .: 0 .: RNil) :< Leaf "t\776")) (cofree ((range2 .: StringLiteral .: 0 .: 0 .: RNil) :< Leaf "\7831"))))
 
     where
       range = Range 0 2

test/PatchOutputSpec.hs

@@ -2,7 +2,7 @@ module PatchOutputSpec where
 
 import Prologue
 import Data.Functor.Both
-import Info
+import Data.Record
 import Range
 import Renderer.Patch
 import Source
@@ -14,4 +14,4 @@ spec :: Spec
 spec = parallel $
   describe "hunks" $
     it "empty diffs have empty hunks" $
-        hunks (free . Free $ pure (Info (Range 0 0) StringLiteral 1 0) :< Leaf "") (both (SourceBlob (fromList "") "abcde" "path2.txt" (Just defaultPlainBlob)) (SourceBlob (fromList "") "xyz" "path2.txt" (Just defaultPlainBlob))) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}]
+        hunks (free . Free $ pure (Range 0 0 .: StringLiteral .: 1 .: 0 .: RNil) :< Leaf "") (both (SourceBlob (fromList "") "abcde" "path2.txt" (Just defaultPlainBlob)) (SourceBlob (fromList "") "xyz" "path2.txt" (Just defaultPlainBlob))) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}]