diff --git a/semantic.cabal b/semantic.cabal index 501cef089..bc2b75345 100644 --- a/semantic.cabal +++ b/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 diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index f62438294..82e6d5385 100644 --- a/src/Analysis/CallGraph.hs +++ b/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 diff --git a/src/Analysis/CyclomaticComplexity.hs b/src/Analysis/CyclomaticComplexity.hs index 4219768d4..4d5f2033e 100644 --- a/src/Analysis/CyclomaticComplexity.hs +++ b/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 diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index 3c00b5f4a..2beab85d2 100644 --- a/src/Assigning/Assignment.hs +++ b/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 diff --git a/src/Assigning/Assignment/Table.hs b/src/Assigning/Assignment/Table.hs index ad05a05b0..2acb031db 100644 --- a/src/Assigning/Assignment/Table.hs +++ b/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) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 2026e572c..9d8a15345 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/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 diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0c7b90914..535d4d3bc 100644 --- a/src/Control/Abstract/Value.hs +++ b/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 diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index a843605a7..d11299928 100644 --- a/src/Data/Abstract/Live.hs +++ b/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 diff --git a/src/Data/Patch.hs b/src/Data/Patch.hs index b8865edc7..952de6abf 100644 --- a/src/Data/Patch.hs +++ b/src/Data/Patch.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Data.Patch ( Patch(..) diff --git a/src/Data/Range.hs b/src/Data/Range.hs index 4f4b74d0a..a5e203310 100644 --- a/src/Data/Range.hs +++ b/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 diff --git a/src/Data/Source.hs b/src/Data/Source.hs index ad97ca0ac..3de66b0cd 100644 --- a/src/Data/Source.hs +++ b/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 diff --git a/src/Data/SplitDiff.hs b/src/Data/SplitDiff.hs index bcbc565bc..3bf57d28f 100644 --- a/src/Data/SplitDiff.hs +++ b/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) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index eee18eab8..d9b3f3917 100644 --- a/src/Data/Syntax.hs +++ b/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 diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index f32c5ddd5..b0381548a 100644 --- a/src/Diffing/Algorithm.hs +++ b/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 diff --git a/src/Diffing/Algorithm/RWS.hs b/src/Diffing/Algorithm/RWS.hs index 5c3b21300..ad2980455 100644 --- a/src/Diffing/Algorithm/RWS.hs +++ b/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 diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 7bb9f2d02..04ea43195 100644 --- a/src/Diffing/Interpreter.hs +++ b/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) diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index 57441a432..1bbd21dae 100644 --- a/src/Language/Go/Assignment.hs +++ b/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 diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs index 6882c8aa7..d4588e439 100644 --- a/src/Language/Markdown/Assignment.hs +++ b/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) diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs index d6268087a..d2c5dcf0d 100644 --- a/src/Language/Python/Assignment.hs +++ b/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. diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 8157e9262..ae1c5ffab 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/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. diff --git a/src/Rendering/Imports.hs b/src/Rendering/Imports.hs index ea6f08e04..4e1e28e4b 100644 --- a/src/Rendering/Imports.hs +++ b/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 diff --git a/src/Rendering/SExpression.hs b/src/Rendering/SExpression.hs index 7c6edb22d..fe5aad592 100644 --- a/src/Rendering/SExpression.hs +++ b/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 diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 965b9a010..3fd0f6899 100644 --- a/src/Rendering/TOC.hs +++ b/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 diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e41b90f52..0d8520ec7 100644 --- a/src/Semantic/Util.hs +++ b/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)))