Merge remote-tracking branch 'origin/master' into classes

semantic.cabal

@@ -181,16 +181,16 @@ library
                      , tree-sitter-ruby
                      , tree-sitter-typescript
   default-language:    Haskell2010
-  default-extensions: DeriveFoldable
-                    , DeriveFunctor
-                    , DeriveGeneric
-                    , DeriveTraversable
-                    , FlexibleContexts
-                    , FlexibleInstances
-                    , OverloadedStrings
-                    , RecordWildCards
-                    , StrictData
-  ghc-options:         -Wall -fno-warn-name-shadowing -O -j
+  default-extensions:  DeriveFoldable
+                     , DeriveFunctor
+                     , DeriveGeneric
+                     , DeriveTraversable
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , OverloadedStrings
+                     , RecordWildCards
+                     , StrictData
+  ghc-options:         -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O -j
   ghc-prof-options:    -fprof-auto
 
 executable semantic

src/Analysis/CallGraph.hs

@@ -21,7 +21,7 @@ newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name }
   deriving (Eq, Graph, Show)
 
 -- | Build the 'CallGraph' for a 'Term' recursively.
-buildCallGraph :: (CallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph
+buildCallGraph :: (CallGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph
 buildCallGraph = foldSubterms callGraphAlgebra
 
 
@@ -91,10 +91,12 @@ type family CallGraphAlgebraStrategy syntax where
   CallGraphAlgebraStrategy (TermF f a) = 'Custom
   CallGraphAlgebraStrategy a = 'Default
 
+instance Semigroup CallGraph where
+  (<>) = overlay
 
 instance Monoid CallGraph where
   mempty = empty
-  mappend = overlay
+  mappend = (<>)
 
 instance Ord CallGraph where
   compare (CallGraph G.Empty)           (CallGraph G.Empty)           = EQ

src/Analysis/CyclomaticComplexity.hs

@@ -31,7 +31,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int
 --   If you’re getting errors about missing a 'CustomHasCyclomaticComplexity' instance for your syntax type, you probably forgot step 1.
 --
 --   If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
-cyclomaticComplexityAlgebra :: (Foldable syntax, HasCyclomaticComplexity syntax) => TermF syntax ann CyclomaticComplexity -> CyclomaticComplexity
+cyclomaticComplexityAlgebra :: HasCyclomaticComplexity syntax => TermF syntax ann CyclomaticComplexity -> CyclomaticComplexity
 cyclomaticComplexityAlgebra (In _ syntax) = toCyclomaticComplexity syntax
 
 

src/Assigning/Assignment.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 -- | Assignment of AST onto some other structure (typically terms).
 --
 --   Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and Span). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference.
@@ -303,7 +304,7 @@ instance (Enum grammar, Eq1 ast, Ix grammar) => Semigroup (Assignment ast gramma
 
 instance (Enum grammar, Eq1 ast, Ix grammar) => Monoid (Assignment ast grammar a) where
   mempty = empty
-  mappend = (<|>)
+  mappend = (<>)
 
 instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast grammar) where
   empty :: HasCallStack => Assignment ast grammar a

src/Assigning/Assignment/Table.hs

@@ -6,7 +6,7 @@ module Assigning.Assignment.Table
 , lookup
 ) where
 
-import Prologue hiding (toList)
+import Prologue
 import Prelude hiding (lookup)
 import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
@@ -18,7 +18,7 @@ data Table i a = Table { tableAddresses :: [i], tableBranches :: IntMap a }
 singleton :: Enum i => i -> a -> Table i a
 singleton i a = Table [i] (IntMap.singleton (fromEnum i) a)
 
-fromListWith :: (Enum i, Ord i) => (a -> a -> a) -> [(i, a)] -> Table i a
+fromListWith :: Enum i => (a -> a -> a) -> [(i, a)] -> Table i a
 fromListWith with assocs = Table (toEnum <$> IntSet.toList (IntSet.fromList (fromEnum . fst <$> assocs))) (IntMap.fromListWith with (first fromEnum <$> assocs))
 
 toPairs :: Enum i => Table i a -> [(i, a)]
@@ -29,9 +29,12 @@ lookup :: Enum i => i -> Table i a -> Maybe a
 lookup i = IntMap.lookup (fromEnum i) . tableBranches
 
 
+instance (Enum i, Monoid a) => Semigroup (Table i a) where
+  (Table i1 b1) <> (Table i2 b2) = Table (i1 `mappend` i2) (IntMap.unionWith mappend b1 b2)
+
 instance (Enum i, Monoid a) => Monoid (Table i a) where
   mempty = Table mempty mempty
-  mappend (Table i1 b1) (Table i2 b2) = Table (i1 `mappend` i2) (IntMap.unionWith mappend b1 b2)
+  mappend = (<>)
 
 instance (Enum i, Show i) => Show1 (Table i) where
   liftShowsPrec spA slA d t = showsBinaryWith showsPrec (const (liftShowList spA slA)) "Table" d (tableAddresses t) (toPairs t)

src/Control/Abstract/Analysis.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis
 module Control.Abstract.Analysis
 ( MonadAnalysis(..)
 , evaluateTerm

src/Control/Abstract/Value.hs

@@ -138,7 +138,6 @@ doWhile body cond = loop $ \ continue -> body *> do
 instance ( Monad m
          , MonadAddressable location Value m
          , MonadAnalysis term Value m
-         , Show location
          )
          => MonadValue Value m where
 
@@ -265,6 +264,8 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon
 
   objectEnvironment _ = pure mempty
 
+  asString _ = fail "Must evaluate to Value to use asString"
+
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 
   liftNumeric _ Type.Float = pure Type.Float

src/Data/Abstract/Live.hs

@@ -31,7 +31,7 @@ liveMember :: Ord l => Address l v -> Live l v -> Bool
 liveMember addr = Set.member addr . unLive
 
 -- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty.
-liveSplit :: Ord l => Live l v -> Maybe (Address l v, Live l v)
+liveSplit :: Live l v -> Maybe (Address l v, Live l v)
 liveSplit = fmap (second Live) . Set.minView . unLive
 
 

src/Data/Patch.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 module Data.Patch
 ( Patch(..)

src/Data/Range.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE DeriveAnyClass #-}
 module Data.Range
 ( Range(..)
+, emptyRange
 , rangeLength
 , offsetRange
 , intersectsRange
@@ -15,6 +15,9 @@ import Data.JSON.Fields
 data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int }
   deriving (Eq, Show, Generic)
 
+emptyRange :: Range
+emptyRange = Range 0 0
+
 -- | Return the length of the range.
 rangeLength :: Range -> Int
 rangeLength range = end range - start range

src/Data/Source.hs

@@ -61,7 +61,7 @@ totalRange = Range 0 . B.length . sourceBytes
 totalSpan :: Source -> Span
 totalSpan source = Span (Pos 1 1) (Pos (length ranges) (succ (end lastRange - start lastRange)))
   where ranges = sourceLineRanges source
-        Just lastRange = getLast (foldMap (Last . Just) ranges)
+        lastRange = fromMaybe emptyRange (getLast (foldMap (Last . Just) ranges))
 
 
 -- En/decoding
@@ -150,8 +150,8 @@ rangeToSpan source (Range rangeStart rangeEnd) = Span startPos endPos
         firstLine = length before
         (before, rest) = span ((< rangeStart) . end) (sourceLineRanges source)
         (lineRanges, _) = span ((<= rangeEnd) . start) rest
-        Just firstRange = getFirst (foldMap (First . Just) lineRanges)
-        Just lastRange  = getLast  (foldMap (Last  . Just) lineRanges)
+        firstRange = fromMaybe emptyRange (getFirst (foldMap (First . Just) lineRanges))
+        lastRange  = fromMaybe firstRange (getLast (foldMap (Last . Just) lineRanges))
 
 
 -- Instances

src/Data/SplitDiff.hs

@@ -13,7 +13,7 @@ data SplitPatch a
   deriving (Foldable, Eq, Functor, Show, Traversable)
 
 -- | Get the range of a SplitDiff.
-getRange :: Functor f => HasField fields Range => SplitDiff f (Record fields) -> Range
+getRange :: HasField fields Range => SplitDiff f (Record fields) -> Range
 getRange diff = getField $ case diff of
   Free annotated -> termFAnnotation annotated
   Pure patch -> termAnnotation (splitTerm patch)

src/Data/Syntax.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 module Data.Syntax where
 
 import Control.Monad.Fail

src/Diffing/Algorithm.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds, DefaultSignatures, GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- FIXME
 module Diffing.Algorithm where
 
 import Prologue

src/Diffing/Algorithm/RWS.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GADTs, DataKinds, RankNTypes, TypeOperators #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- FIXME
 module Diffing.Algorithm.RWS
 ( rws
 , Options(..)
@@ -98,7 +99,7 @@ defaultP = 0
 defaultQ = 3
 
 
-toKdMap :: Functor syntax => [(Int, Term syntax (Record (FeatureVector ': fields)))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (Record (FeatureVector ': fields)))
+toKdMap :: [(Int, Term syntax (Record (FeatureVector ': fields)))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (Record (FeatureVector ': fields)))
 toKdMap = KdMap.build unFV . fmap (rhead . termAnnotation . snd &&& id)
 
 -- | 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.
@@ -134,8 +135,7 @@ pqGramDecorator getLabel p q = cata algebra
     gram label = Gram (padToSize p []) (padToSize q (pure (Just label)))
     assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label))
 
-    assignLabels :: Functor f
-                 => label
+    assignLabels :: label
                  -> Term f (Record (Gram label ': fields))
                  -> State [Maybe label] (Term f (Record (Gram label ': fields)))
     assignLabels label (Term.Term (In (gram :. rest) functor)) = do

src/Diffing/Interpreter.hs

@@ -14,7 +14,7 @@ import Diffing.Algorithm
 import Diffing.Algorithm.RWS
 
 -- | Diff two à la carte terms recursively.
-diffTerms :: (Diffable syntax, Eq1 syntax, Foldable syntax, Functor syntax, GAlign syntax, Show1 syntax, Traversable syntax)
+diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax)
           => Term syntax (Record fields1)
           -> Term syntax (Record fields2)
           -> Diff syntax (Record fields1) (Record fields2)

src/Language/Go/Assignment.hs

@@ -598,8 +598,7 @@ infixTerm :: Assignment
 infixTerm = infixContext comment
 
 -- | Match a series of terms or comments until a delimiter is matched
-manyTermsTill :: Show b
-              => Assignment.Assignment [] Grammar Term
+manyTermsTill :: Assignment.Assignment [] Grammar Term
               -> Assignment.Assignment [] Grammar b
               -> Assignment.Assignment [] Grammar [Term]
 manyTermsTill step end = manyTill (step <|> comment) end

src/Language/Markdown/Assignment.hs

@@ -6,17 +6,18 @@ module Language.Markdown.Assignment
 , Language.Markdown.Assignment.Term
 ) where
 
-import Prologue
 import Assigning.Assignment hiding (Assignment, Error)
-import qualified Assigning.Assignment as Assignment
-import qualified CMarkGFM
 import Data.Record
 import Data.Syntax (makeTerm)
-import qualified Data.Syntax as Syntax
 import Data.Term as Term (Term(..), TermF(..), termFAnnotation, termFOut, termIn)
-import qualified Data.Text as Text
 import Data.Text.Encoding (encodeUtf8)
 import Parsing.CMark as Grammar (Grammar(..))
+import Prologue
+import qualified Assigning.Assignment as Assignment
+import qualified CMarkGFM
+import qualified Data.ByteString as B
+import qualified Data.Syntax as Syntax
+import qualified Data.Text as Text
 import qualified Language.Markdown.Syntax as Markup
 
 type Syntax =
@@ -72,21 +73,30 @@ paragraph :: Assignment
 paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement)
 
 list :: Assignment
-list = termIn <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of
-  CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList
-  CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termFAnnotation . termFOut <$> currentNode <*> children (many item))
+list = termIn <$> symbol List <*> (makeList . termFAnnotation . termFOut <$> currentNode <*> children (many item))
+  where
+    makeList (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) = case listType of
+      CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList
+      CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList
+    makeList _ = inj . Markup.UnorderedList
 
 item :: Assignment
 item = makeTerm <$> symbol Item <*> children (many blockElement)
 
 heading :: Assignment
-heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termFAnnotation . termFOut <$> currentNode <*> children (many inlineElement) <*> manyTill blockElement (void (symbol Heading) <|> eof))
+heading = makeTerm <$> symbol Heading <*> (makeHeading . termFAnnotation . termFOut <$> currentNode <*> children (many inlineElement) <*> manyTill blockElement (void (symbol Heading) <|> eof))
+  where
+    makeHeading (CMarkGFM.HEADING level) = Markup.Heading level
+    makeHeading _ = Markup.Heading 0
 
 blockQuote :: Assignment
 blockQuote = makeTerm <$> symbol BlockQuote <*> children (Markup.BlockQuote <$> many blockElement)
 
 codeBlock :: Assignment
-codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . termFAnnotation . termFOut <$> currentNode <*> source)
+codeBlock = makeTerm <$> symbol CodeBlock <*> (makeCode . termFAnnotation . termFOut <$> currentNode <*> source)
+  where
+    makeCode (CMarkGFM.CODE_BLOCK language _) = Markup.Code (nullText language)
+    makeCode _ = Markup.Code Nothing
 
 thematicBreak :: Assignment
 thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak
@@ -135,10 +145,16 @@ htmlInline :: Assignment
 htmlInline = makeTerm <$> symbol HTMLInline <*> (Markup.HTMLBlock <$> source)
 
 link :: Assignment
-link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . termFAnnotation . termFOut <$> currentNode) <* advance
+link = makeTerm <$> symbol Link <*> (makeLink . termFAnnotation . termFOut <$> currentNode) <* advance
+  where
+    makeLink (CMarkGFM.LINK url title) = Markup.Link (encodeUtf8 url) (nullText title)
+    makeLink _ = Markup.Link B.empty Nothing
 
 image :: Assignment
-image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termFAnnotation . termFOut <$> currentNode) <* advance
+image = makeTerm <$> symbol Image <*> (makeImage . termFAnnotation . termFOut <$> currentNode) <* advance
+  where
+    makeImage (CMarkGFM.IMAGE url title) = Markup.Image (encodeUtf8 url) (nullText title)
+    makeImage _ = Markup.Image B.empty Nothing
 
 code :: Assignment
 code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source)

src/Language/Python/Assignment.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 module Language.Python.Assignment
 ( assignment
 , Syntax
@@ -501,7 +502,7 @@ chainl1Term :: Assignment -> Assignment.Assignment [] Grammar (Term -> Term -> T
 chainl1Term expr op = postContextualize (comment <|> symbol AnonLambda *> empty) expr `chainl1` op
 
 -- | Match a series of terms or comments until a delimiter is matched.
-manyTermsTill :: Show b => Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term]
+manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term]
 manyTermsTill step end = manyTill (step <|> comment) end
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.

src/Language/Ruby/Assignment.hs

@@ -411,7 +411,7 @@ term :: Assignment -> Assignment
 term term = contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)
 
 -- | Match a series of terms or comments until a delimiter is matched.
-manyTermsTill :: Show b => Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term]
+manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term]
 manyTermsTill step end = manyTill (step <|> comment) end
 
 -- | Match infix terms separated by any of a list of operators, assigning any comments following each operand.

src/Rendering/Imports.hs

@@ -22,9 +22,12 @@ import Rendering.TOC (termTableOfContentsBy, declaration, getDeclaration, toCate
 
 newtype ImportSummary = ImportSummary (Map.Map T.Text Module) deriving (Eq, Show)
 
+instance Semigroup ImportSummary where
+  (<>) (ImportSummary m1) (ImportSummary m2) = ImportSummary (Map.unionWith mappend m1 m2)
+
 instance Monoid ImportSummary where
   mempty = ImportSummary mempty
-  mappend (ImportSummary m1) (ImportSummary m2) = ImportSummary (Map.unionWith mappend m1 m2)
+  mappend = (<>)
 
 instance Output ImportSummary where
   toOutput = toStrict . (<> "\n") . encode
@@ -87,9 +90,12 @@ data Module = Module
   , moduleCalls :: [CallExpression]
   } deriving (Generic, Eq, Show)
 
+instance Semigroup Module where
+  (<>) (Module n1 p1 l1 i1 d1 r1) (Module _ p2 _ i2 d2 r2) = Module n1 (p1 <> p2) l1 (i1 <> i2) (d1 <> d2) (r1 <> r2)
+
 instance Monoid Module where
   mempty = mempty
-  mappend (Module n1 p1 l1 i1 d1 r1) (Module _ p2 _ i2 d2 r2) = Module n1 (p1 <> p2) l1 (i1 <> i2) (d1 <> d2) (r1 <> r2)
+  mappend = (<>)
 
 instance ToJSON Module where
   toJSON Module{..} = object

src/Rendering/SExpression.hs

@@ -20,7 +20,7 @@ renderSExpressionDiff diff = cata printDiffF diff 0 <> "\n"
 renderSExpressionTerm :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Term syntax (Record fields) -> ByteString
 renderSExpressionTerm term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF term n) term 0 <> "\n"
 
-printDiffF :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => DiffF syntax (Record fields) (Record fields) (Int -> ByteString) -> Int -> ByteString
+printDiffF :: (ConstrainAll Show fields, Foldable syntax) => DiffF syntax (Record fields) (Record fields) (Int -> ByteString) -> Int -> ByteString
 printDiffF diff n = case diff of
   Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}"
   Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF term n <> "+}"
@@ -28,7 +28,7 @@ printDiffF diff n = case diff of
                               <> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF term2 n <> " }"
   Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showAnnotation ann <> foldMap (\ d -> d (n + 1)) syntax <> ")"
 
-printTermF :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => TermF syntax (Record fields) (Int -> ByteString) -> Int -> ByteString
+printTermF :: (ConstrainAll Show fields, Foldable syntax) => TermF syntax (Record fields) (Int -> ByteString) -> Int -> ByteString
 printTermF (In annotation syntax) n = "(" <> showAnnotation annotation <> foldMap (\t -> t (n + 1)) syntax <> ")"
 
 nl :: Int -> ByteString

src/Rendering/TOC.hs

@@ -37,9 +37,12 @@ import qualified Data.Text as T
 data Summaries = Summaries { changes, errors :: !(Map.Map T.Text [Value]) }
   deriving (Eq, Show)
 
+instance Semigroup Summaries where
+  (<>) (Summaries c1 e1) (Summaries c2 e2) = Summaries (Map.unionWith (<>) c1 c2) (Map.unionWith (<>) e1 e2)
+
 instance Monoid Summaries where
   mempty = Summaries mempty mempty
-  mappend (Summaries c1 e1) (Summaries c2 e2) = Summaries (Map.unionWith (<>) c1 c2) (Map.unionWith (<>) e1 e2)
+  mappend = (<>)
 
 instance Output Summaries where
   toOutput = toStrict . (<> "\n") . encode
@@ -118,8 +121,7 @@ newtype DedupeKey = DedupeKey (Maybe T.Text, Maybe T.Text) deriving (Eq, Ord)
 dedupe :: forall fields. HasField fields (Maybe Declaration) => [Entry (Record fields)] -> [Entry (Record fields)]
 dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in (fmap . fmap) snd tuples
   where
-    go :: HasField fields (Maybe Declaration)
-       => (Int, Map.Map DedupeKey (Int, Entry (Record fields)))
+    go :: (Int, Map.Map DedupeKey (Int, Entry (Record fields)))
        -> Entry (Record fields)
        -> (Int, Map.Map DedupeKey (Int, Entry (Record fields)))
     go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey x) m

src/Semantic/Util.hs

@@ -94,26 +94,29 @@ file :: MonadIO m => FilePath -> m Blob
 file path = fromJust <$> IO.readFile path (languageForFilePath path)
 
 -- Diff helpers
-diffWithParser :: (HasField fields Data.Span.Span,
-                   HasField fields Range,
-                   Eq1 syntax, Show1 syntax,
-                   Traversable syntax, Functor syntax,
-                   Foldable syntax, Diffable syntax,
-                   GAlign syntax, HasDeclaration syntax)
-                  =>
-                  Parser (Term syntax (Record fields))
-                  -> BlobPair
-                  -> Task (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
+diffWithParser ::
+               ( HasField fields Data.Span.Span
+               , HasField fields Range
+               , Eq1 syntax
+               , Show1 syntax
+               , Traversable syntax
+               , Diffable syntax
+               , GAlign syntax
+               , HasDeclaration syntax
+               )
+               => Parser (Term syntax (Record fields))
+               -> BlobPair
+               -> Task (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
 diffWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))
   where
     run parse blobs = bidistributeFor (runJoin blobs) parse parse >>= diffTermPair diffTerms
 
-diffBlobWithParser :: (HasField fields Data.Span.Span,
-                   HasField fields Range,
-                   Eq1 syntax, Show1 syntax,
-                   Traversable syntax, Functor syntax,
-                   Foldable syntax, Diffable syntax,
-                   GAlign syntax, HasDeclaration syntax)
+diffBlobWithParser ::
+                   ( HasField fields Data.Span.Span
+                   , HasField fields Range
+                   , Traversable syntax
+                   , HasDeclaration syntax
+                   )
                   => Parser (Term syntax (Record fields))
                   -> Blob
                   -> Task (Term syntax (Record (Maybe Declaration : fields)))