github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'musical-modules' into 🔥-monolithic-syntax

Browse Source
This commit is contained in:
Rob Rix 2017-11-28 11:59:28 -05:00
commit f1c4b58797
68 changed files with 726 additions and 645 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ghci
View File

@ -25,7 +25,7 @@ assignmentExample lang = case lang of
"Markdown" -> mk "md" "markdown"
"JSON" -> mk "json" "json"
_ -> mk "" ""
where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parser\nimport Semantic.Task\nimport Semantic.Util")
where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util")
:}
:undef assignment
:def assignment assignmentExample

5
app/Main.hs
View File

@ -1,3 +1,2 @@
module Main (main)
where
import SemanticCmdLine (main)
module Main (main) where
import Semantic.CLI (main)

79
semantic-diff.cabal
View File

@ -13,8 +13,19 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Algorithm
exposed-modules:
-- Analyses & term annotations
Analysis.ConstructorName
, Analysis.CyclomaticComplexity
, Analysis.Decorator
, Analysis.Declaration
-- Semantic assignment
, Assigning.Assignment
, Assigning.Assignment.Table
-- General datatype definitions & generic algorithms
, Data.Algebra
, Data.Align.Generic
, Data.AST
, Data.Blob
, Data.Diff
, Data.Error
@ -23,6 +34,7 @@ library
, Data.Functor.Classes.Ord.Generic
, Data.Functor.Classes.Show.Generic
, Data.JSON.Fields
, Data.Language
, Data.Mergeable
, Data.Output
, Data.Patch
@ -31,10 +43,8 @@ library
, Data.Source
, Data.Span
, Data.SplitDiff
-- À la carte syntax types
, Data.Syntax
, Data.Syntax.Algebra
, Data.Syntax.Assignment
, Data.Syntax.Assignment.Table
, Data.Syntax.Comment
, Data.Syntax.Declaration
, Data.Syntax.Expression
@ -42,10 +52,13 @@ library
, Data.Syntax.Statement
, Data.Syntax.Type
, Data.Term
, Files
, Interpreter
, Language
, Language.Markdown
-- Diffing algorithms & interpretation thereof
, Diffing.Algorithm
, Diffing.Algorithm.RWS
, Diffing.Algorithm.RWS.FeatureVector
, Diffing.Algorithm.SES
, Diffing.Interpreter
-- Language-specific grammar/syntax types, & assignments
, Language.Markdown.Assignment
, Language.Markdown.Syntax
, Language.Go.Grammar
@ -62,24 +75,26 @@ library
, Language.Python.Assignment
, Language.Python.Grammar
, Language.Python.Syntax
, Parser
-- Parser glue
, Parsing.CMark
, Parsing.Parser
, Parsing.TreeSitter
, Paths_semantic_diff
, Renderer
, Renderer.JSON
, Renderer.SExpression
, Renderer.Tag
, Renderer.TOC
, RWS
, RWS.FeatureVector
-- Rendering formats
, Rendering.JSON
, Rendering.Renderer
, Rendering.SExpression
, Rendering.Tag
, Rendering.TOC
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic
, Semantic.CLI
, Semantic.IO
, Semantic.Log
, Semantic.Stat
, Semantic.Task
, Semantic.Queue
, Semantic.Util
, SemanticCmdLine
, SES
, TreeSitter
build-depends: base >= 4.8 && < 5
, aeson
, ansi-terminal
@ -142,23 +157,23 @@ test-suite test
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Spec.hs
other-modules: CommandSpec
other-modules: Assigning.Assignment.Spec
, Data.Diff.Spec
, Data.Functor.Classes.Ord.Generic.Spec
, Data.Functor.Listable
, Data.Mergeable.Spec
, Data.RandomWalkSimilarity.Spec
, Data.Syntax.Assignment.Spec
, DiffSpec
, SemanticSpec
, SemanticCmdLineSpec
, Semantic.StatSpec
, InterpreterSpec
, SES.Spec
, SourceSpec
, Data.Source.Spec
, Data.Term.Spec
, Diffing.Algorithm.RWS.Spec
, Diffing.Algorithm.SES.Spec
, Diffing.Interpreter.Spec
, Integration.Spec
, Rendering.TOC.Spec
, Semantic.Spec
, Semantic.CLI.Spec
, Semantic.IO.Spec
, Semantic.Stat.Spec
, SpecHelpers
, TermSpec
, TOCSpec
, IntegrationSpec
, Test.Hspec.LeanCheck
build-depends: aeson
, array

78
src/Analysis/ConstructorName.hs Normal file
View File

@ -0,0 +1,78 @@
{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.ConstructorName
( ConstructorName(..)
, ConstructorLabel(..)
, constructorLabel
) where
import Data.Aeson
import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.JSON.Fields
import Data.Proxy
import Data.Term
import Data.Text.Encoding (decodeUtf8)
import Data.Union
import GHC.Generics
-- | Compute a 'ConstructorLabel' label for a 'Term'.
constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel
constructorLabel (In _ s) = ConstructorLabel $ pack (constructorName s)
newtype ConstructorLabel = ConstructorLabel ByteString
instance Show ConstructorLabel where
showsPrec _ (ConstructorLabel s) = showString (unpack s)
instance ToJSONFields ConstructorLabel where
toJSONFields (ConstructorLabel s) = [ "category" .= decodeUtf8 s ]
-- | A typeclass to retrieve the name of the data constructor for a value.
--
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap; see also src/Analysis/Declaration.hs for discussion of the details of the mechanism.
class ConstructorName syntax where
constructorName :: syntax a -> String
instance (ConstructorNameStrategy syntax ~ strategy, ConstructorNameWithStrategy strategy syntax) => ConstructorName syntax where
constructorName = constructorNameWithStrategy (Proxy :: Proxy strategy)
class CustomConstructorName syntax where
customConstructorName :: syntax a -> String
instance Apply ConstructorName fs => CustomConstructorName (Union fs) where
customConstructorName = apply (Proxy :: Proxy ConstructorName) constructorName
instance CustomConstructorName [] where
customConstructorName [] = "[]"
customConstructorName _ = ""
data Strategy = Default | Custom
type family ConstructorNameStrategy syntax where
ConstructorNameStrategy (Union _) = 'Custom
ConstructorNameStrategy [] = 'Custom
ConstructorNameStrategy syntax = 'Default
class ConstructorNameWithStrategy (strategy :: Strategy) syntax where
constructorNameWithStrategy :: proxy strategy -> syntax a -> String
instance (Generic1 syntax, GConstructorName (Rep1 syntax)) => ConstructorNameWithStrategy 'Default syntax where
constructorNameWithStrategy _ = gconstructorName . from1
instance CustomConstructorName syntax => ConstructorNameWithStrategy 'Custom syntax where
constructorNameWithStrategy _ = customConstructorName
class GConstructorName f where
gconstructorName :: f a -> String
instance GConstructorName f => GConstructorName (M1 D c f) where
gconstructorName = gconstructorName . unM1
instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g) where
gconstructorName (L1 l) = gconstructorName l
gconstructorName (R1 r) = gconstructorName r
instance Constructor c => GConstructorName (M1 C c f) where
gconstructorName = conName

26
src/Analysis/CyclomaticComplexity.hs Normal file
View File

@ -0,0 +1,26 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators #-}
module Analysis.CyclomaticComplexity
( cyclomaticComplexityAlgebra
) where
import Data.Algebra (FAlgebra)
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Statement as Statement
import Data.Term
import Data.Union
-- | The cyclomatic complexity of a (sub)term.
newtype CyclomaticComplexity = CyclomaticComplexity Int
deriving (Enum, Eq, Num, Ord, Show)
-- | Compute the cyclomatic complexity of a (sub)term, measured as the number places where control exits scope, e.g. returns and yields.
--
-- TODO: Explicit returns at the end of methods should only count once.
-- TODO: Anonymous functions should not increase parent scope’s complexity.
-- TODO: Inner functions should not increase parent scope’s complexity.
cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply Foldable fs, Apply Functor fs) => FAlgebra (Term (Union fs) a) CyclomaticComplexity
cyclomaticComplexityAlgebra (In _ union) = case union of
_ | Just Declaration.Method{} <- prj union -> succ (sum union)
_ | Just Statement.Return{} <- prj union -> succ (sum union)
_ | Just Statement.Yield{} <- prj union -> succ (sum union)
_ -> sum union

220
src/Renderer/TOC.hs → src/Analysis/Declaration.hs
View File

@ -1,92 +1,30 @@
{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Renderer.TOC
( renderToCDiff
, renderToCTerm
, diffTOC
, Summaries(..)
, TOCSummary(..)
, isValidSummary
, Declaration(..)
, getDeclaration
, declaration
{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
module Analysis.Declaration
( Declaration(..)
, HasDeclaration
, declarationAlgebra
, Entry(..)
, tableOfContentsBy
, termTableOfContentsBy
, dedupe
, entrySummary
, toCategoryName
) where
import Data.Aeson
import Data.Align (bicrosswalk)
import Data.Bifoldable (bifoldMap)
import Data.Bifunctor (bimap)
import Data.Algebra
import Data.Blob
import Data.ByteString.Lazy (toStrict)
import Data.Diff
import Data.Error as Error (Error(..), showExpectation)
import Data.Foldable (fold, foldl', toList)
import Data.Functor.Both hiding (fst, snd)
import Data.Functor.Foldable (cata)
import Data.Function (on)
import Data.Error (Error(..), showExpectation)
import Data.Foldable (toList)
import Data.Language
import Data.List.NonEmpty (nonEmpty)
import Data.List (sortOn)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Output
import Data.Patch
import Data.Proxy
import Data.Proxy (Proxy(..))
import Data.Range
import Data.Record
import Data.Semigroup ((<>), sconcat)
import Data.Source as Source
import Data.Semigroup (sconcat)
import Data.Span
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import Data.Term
import Data.Text (toLower, stripEnd)
import qualified Data.Text as T
import Data.Union
import GHC.Generics
import Language
import qualified Data.List as List
import qualified Data.Map as Map hiding (null)
import Data.Syntax.Algebra (RAlgebra)
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import qualified Language.Markdown.Syntax as Markdown
data Summaries = Summaries { changes, errors :: !(Map.Map T.Text [Value]) }
deriving (Eq, Show)
instance Monoid Summaries where
mempty = Summaries mempty mempty
mappend (Summaries c1 e1) (Summaries c2 e2) = Summaries (Map.unionWith (<>) c1 c2) (Map.unionWith (<>) e1 e2)
instance Output Summaries where
toOutput = toStrict . (<> "\n") . encode
instance ToJSON Summaries where
toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ]
data TOCSummary
= TOCSummary
{ summaryCategoryName :: T.Text
, summaryTermName :: T.Text
, summarySpan :: Span
, summaryChangeType :: T.Text
}
| ErrorSummary { error :: T.Text, errorSpan :: Span, errorLanguage :: Maybe Language }
deriving (Generic, Eq, Show)
instance ToJSON TOCSummary where
toJSON TOCSummary{..} = object [ "changeType" .= summaryChangeType, "category" .= summaryCategoryName, "term" .= summaryTermName, "span" .= summarySpan ]
toJSON ErrorSummary{..} = object [ "error" .= error, "span" .= errorSpan, "language" .= errorLanguage ]
isValidSummary :: TOCSummary -> Bool
isValidSummary ErrorSummary{} = False
isValidSummary _ = True
-- | A declaration’s identifier and type.
data Declaration
= MethodDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationReceiver :: Maybe T.Text }
@ -107,7 +45,7 @@ data Declaration
-- If you’re getting errors about missing a 'CustomHasDeclaration' 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.
declarationAlgebra :: (HasField fields Range, HasField fields Span, Foldable syntax, HasDeclaration syntax) => Blob -> RAlgebra (TermF syntax (Record fields)) (Term syntax (Record fields)) (Maybe Declaration)
declarationAlgebra :: (HasField fields Range, HasField fields Span, Foldable syntax, HasDeclaration syntax) => Blob -> RAlgebra (Term syntax (Record fields)) (Maybe Declaration)
declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax
@ -116,7 +54,7 @@ declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasDeclaration syntax where
-- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toDeclaration :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> RAlgebra syntax (Term whole (Record fields)) (Maybe Declaration)
toDeclaration :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe Declaration) -> Maybe Declaration
-- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition.
--
@ -130,7 +68,7 @@ instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy stra
-- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasDeclaration syntax where
-- | Produce a customized 'Declaration' for a given syntax node.
customToDeclaration :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> RAlgebra syntax (Term whole (Record fields)) (Maybe Declaration)
customToDeclaration :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe Declaration) -> Maybe Declaration
-- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node.
@ -146,6 +84,7 @@ instance CustomHasDeclaration Markdown.Heading where
instance CustomHasDeclaration Syntax.Error where
customToDeclaration Blob{..} ann err@Syntax.Error{}
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (getField ann) err))) mempty blobLanguage
where formatTOCError e = showExpectation False (errorExpected e) (errorActual e) ""
-- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range').
instance CustomHasDeclaration Declaration.Function where
@ -163,7 +102,7 @@ instance CustomHasDeclaration Declaration.Method where
-- Methods without a receiver
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage Nothing
-- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
| blobLanguage == Just Language.Go
| blobLanguage == Just Go
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource receiverType))
-- Methods with a receiver (class methods) are formatted like `receiver.method_name`
| otherwise = Just $ MethodDeclaration (getSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource receiverAnn))
@ -189,7 +128,7 @@ data Strategy = Default | Custom
--
-- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class.
class HasDeclarationWithStrategy (strategy :: Strategy) syntax where
toDeclarationWithStrategy :: (Foldable whole, HasField fields Range, HasField fields Span) => proxy strategy -> Blob -> Record fields -> RAlgebra syntax (Term whole (Record fields)) (Maybe Declaration)
toDeclarationWithStrategy :: (Foldable whole, HasField fields Range, HasField fields Span) => proxy strategy -> Blob -> Record fields -> syntax (Term whole (Record fields), Maybe Declaration) -> Maybe Declaration
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.
@ -216,142 +155,23 @@ instance CustomHasDeclaration syntax => HasDeclarationWithStrategy 'Custom synta
toDeclarationWithStrategy _ = customToDeclaration
getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration
getDeclaration = getField
-- | Produce the annotations of nodes representing declarations.
declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields)
declaration (In annotation _) = annotation <$ getDeclaration annotation
getMethodSource :: HasField fields Range => Blob -> TermF Declaration.Method (Record fields) (Term syntax (Record fields), a) -> T.Text
getMethodSource Blob{..} (In a r)
= let declRange = getField a
bodyRange = getField <$> case r of
Declaration.Method _ _ _ _ (Term (In a' _), _) -> Just a'
in maybe mempty (stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
getFunctionSource :: HasField fields Range => Blob -> TermF Declaration.Function (Record fields) (Term syntax (Record fields), a) -> T.Text
getFunctionSource Blob{..} (In a r)
= let declRange = getField a
bodyRange = getField <$> case r of
Declaration.Function _ _ _ (Term (In a' _), _) -> Just a'
in maybe mempty (stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
getClassSource :: (HasField fields Range) => Blob -> TermF Declaration.Class (Record fields) (Term syntax (Record fields), a) -> T.Text
getClassSource Blob{..} (In a r)
= let declRange = getField a
bodyRange = getField <$> case r of
Declaration.Class _ _ _ (Term (In a' _), _) -> Just a'
in maybe mempty (stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
formatTOCError :: Error.Error String -> String
formatTOCError e = showExpectation False (errorExpected e) (errorActual e) ""
-- | An entry in a table of contents.
data Entry a
= Changed { entryPayload :: a } -- ^ An entry for a node containing changes.
| Inserted { entryPayload :: a } -- ^ An entry for a change occurring inside an 'Insert' 'Patch'.
| Deleted { entryPayload :: a } -- ^ An entry for a change occurring inside a 'Delete' 'Patch'.
| Replaced { entryPayload :: a } -- ^ An entry for a change occurring on the insertion side of a 'Replace' 'Patch'.
deriving (Eq, Show)
-- | Compute a table of contents for a diff characterized by a function mapping relevant nodes onto values in Maybe.
tableOfContentsBy :: (Foldable f, Functor f)
=> (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe.
-> Diff f ann ann -- ^ The diff to compute the table of contents for.
-> [Entry a] -- ^ A list of entries for relevant changed nodes in the diff.
tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of
Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just []
Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of
(Just a, Just entries) -> Just (Changed a : entries)
(_ , entries) -> entries)
where patchEntry = patch Deleted Inserted (const Replaced)
termTableOfContentsBy :: (Foldable f, Functor f)
=> (forall b. TermF f annotation b -> Maybe a)
-> Term f annotation
-> [a]
termTableOfContentsBy selector = cata termAlgebra
where termAlgebra r | Just a <- selector r = a : fold r
| otherwise = fold r
newtype DedupeKey = DedupeKey (Maybe T.Text, Maybe T.Text) deriving (Eq, Ord)
-- Dedupe entries in a final pass. This catches two specific scenarios with
-- different behaviors:
-- 1. Identical entries are in the list.
-- Action: take the first one, drop all subsequent.
-- 2. Two similar entries (defined by a case insensitive comparision of their
-- identifiers) are in the list.
-- Action: Combine them into a single Replaced entry.
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)))
-> Entry (Record fields)
-> (Int, Map.Map DedupeKey (Int, Entry (Record fields)))
go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey x) m
= if exactMatch similar x
then (succ index, m)
else
let replacement = Replaced (entryPayload similar)
in (succ index, Map.insert (dedupeKey replacement) (index, replacement) m)
| otherwise = (succ index, Map.insert (dedupeKey x) (index, x) m)
dedupeKey entry = DedupeKey ((fmap toCategoryName . getDeclaration . entryPayload) entry, (fmap (toLower . declarationIdentifier) . getDeclaration . entryPayload) entry)
exactMatch = (==) `on` (getDeclaration . entryPayload)
-- | Construct a 'TOCSummary' from an 'Entry'.
entrySummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Entry (Record fields) -> Maybe TOCSummary
entrySummary entry = case entry of
Changed a -> recordSummary "modified" a
Deleted a -> recordSummary "removed" a
Inserted a -> recordSummary "added" a
Replaced a -> recordSummary "modified" a
-- | Construct a 'TOCSummary' from a node annotation and a change type label.
recordSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => T.Text -> Record fields -> Maybe TOCSummary
recordSummary changeText record = case getDeclaration record of
Just (ErrorDeclaration text _ language) -> Just $ ErrorSummary text (getField record) language
Just declaration -> Just $ TOCSummary (toCategoryName declaration) (formatIdentifier declaration) (getField record) changeText
Nothing -> Nothing
where
formatIdentifier (MethodDeclaration identifier _ (Just Language.Go) (Just receiverTy)) = "(" <> receiverTy <> ") " <> identifier
formatIdentifier (MethodDeclaration identifier _ _ (Just receiver)) = receiver <> "." <> identifier
formatIdentifier declaration = declarationIdentifier declaration
renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) (Record fields) -> Summaries
renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
where toMap [] = mempty
toMap as = Map.singleton summaryKey (toJSON <$> as)
summaryKey = T.pack $ case runJoin (blobPath <$> blobs) of
(before, after) | null before -> after
| null after -> before
| before == after -> after
| otherwise -> before <> " -> " <> after
diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) (Record fields) -> [TOCSummary]
diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration
renderToCTerm :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Blob -> Term f (Record fields) -> Summaries
renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
where
toMap [] = mempty
toMap as = Map.singleton (T.pack blobPath) (toJSON <$> as)
termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Term f (Record fields) -> [TOCSummary]
termToC = mapMaybe (recordSummary "unchanged") . termTableOfContentsBy declaration
-- The user-facing category name
toCategoryName :: Declaration -> T.Text
toCategoryName declaration = case declaration of
ClassDeclaration{} -> "Class"
FunctionDeclaration{} -> "Function"
MethodDeclaration{} -> "Method"
HeadingDeclaration _ _ _ l -> "Heading " <> T.pack (show l)
ErrorDeclaration{} -> "ParseError"
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange

37
src/Analysis/Decorator.hs Normal file
View File

@ -0,0 +1,37 @@
{-# LANGUAGE DataKinds, TypeOperators #-}
module Analysis.Decorator
( decoratorWithAlgebra
, constructorNameAndConstantFields
) where
import Data.Aeson
import Data.Algebra
import Data.Bifunctor (second)
import Data.ByteString.Char8 (ByteString, pack)
import Data.Functor.Classes (Show1 (liftShowsPrec))
import Data.Functor.Foldable
import Data.JSON.Fields
import Data.Record
import Data.Term
import Data.Text.Encoding (decodeUtf8)
-- | Lift an algebra into a decorator for terms annotated with records.
decoratorWithAlgebra :: Functor syntax
=> RAlgebra (Term syntax (Record fs)) a -- ^ An R-algebra on terms.
-> Term syntax (Record fs) -- ^ A term to decorate with values produced by the R-algebra.
-> Term syntax (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra.
decoratorWithAlgebra alg = para $ \ c@(In a f) -> termIn (alg (fmap (second (rhead . termAnnotation)) c) :. a) (fmap snd f)
newtype Identifier = Identifier ByteString
deriving (Eq, Show)
instance ToJSONFields Identifier where
toJSONFields (Identifier i) = [ "identifier" .= decodeUtf8 i ]
-- | Compute a 'ByteString' label for a 'Show1'able 'Term'.
--
-- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that
-- constant fields will be included and parametric fields will not be.
constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString
constructorNameAndConstantFields (In _ f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")

26
src/Data/Syntax/Assignment.hs → src/Assigning/Assignment.hs
View File

@ -59,13 +59,10 @@
-- AST symbols are classified by their 'symbolType' as either 'Regular', 'Anonymous', or 'Auxiliary'. 'Auxiliary' never appears in ASTs; 'Regular' is for the symbols of explicitly named productions in the grammar, and 'Anonymous' is for unnamed productions of content such as tokens. Most of the time, assignments are only concerned with the named productions, and thus will be using 'Regular' symbols. Therefore, when matching a committed choice of all-'Regular' symbols, nodes with 'Anonymous' symbols will be skipped. However, in some cases grammars don’t provide a named symbol for e.g. every kind of infix operator, and thus the only way to differentiate between them is by means of a 'symbol' rule for an 'Anonymous' token. In these cases, and before every other kind of assignment, the 'Anonymous' nodes will not be skipped so that matching can succeed.
--
-- Therefore, in addition to the rule of thumb for committed choices (see above), try to match 'Regular' symbols up front, and only match 'Anonymous' ones in the middle of a chain. That will ensure that you don’t have to make redundant effort to explicitly skip 'Anonymous' nodes ahead of multiple alternatives, and can instead rely on them being automatically skipped except when explicitly required.
module Data.Syntax.Assignment
module Assigning.Assignment
-- Types
( Assignment
, Location
, AST
, Node(..)
, nodeLocation
-- Combinators
, Alternative(..)
, MonadError(..)
@ -95,11 +92,13 @@ module Data.Syntax.Assignment
, module Parsers
) where
import qualified Assigning.Assignment.Table as Table
import Control.Applicative
import Control.Monad ((<=<), guard)
import Control.Monad.Error.Class hiding (Error)
import Control.Monad.Fail
import Control.Monad.Free.Freer
import Data.AST
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Error
@ -114,7 +113,6 @@ import Data.Record
import Data.Semigroup
import qualified Data.Source as Source (Source, slice, sourceBytes)
import Data.Span
import qualified Data.Syntax.Assignment.Table as Table
import Data.Term
import GHC.Stack
import Prelude hiding (fail, until)
@ -216,22 +214,6 @@ manyThrough step stop = go
where go = (,) [] <$> stop <|> first . (:) <$> step <*> go
-- | A location specified as possibly-empty intervals of bytes and line/column positions.
type Location = '[Range, Span]
-- | An AST node labelled with symbols and source location.
type AST f grammar = Term f (Node grammar)
data Node grammar = Node
{ nodeSymbol :: !grammar
, nodeByteRange :: {-# UNPACK #-} !Range
, nodeSpan :: {-# UNPACK #-} !Span
}
deriving (Eq, Show)
nodeLocation :: Node grammar -> Record Location
nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil
nodeError :: HasCallStack => [Either String grammar] -> Node grammar -> Error (Either String grammar)
nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol))
@ -304,7 +286,7 @@ withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallSta
withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action
skipTokens :: Symbol grammar => State ast grammar -> State ast grammar
skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation . unTerm) (stateNodes state) }
skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation) (stateNodes state) }
-- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged.
advanceState :: State ast grammar -> State ast grammar

2
src/Data/Syntax/Assignment/Table.hs → src/Assigning/Assignment/Table.hs
View File

@ -1,4 +1,4 @@
module Data.Syntax.Assignment.Table
module Assigning.Assignment.Table
( Table(tableAddresses)
, singleton
, fromListWith

23
src/Data/AST.hs Normal file
View File

@ -0,0 +1,23 @@
{-# LANGUAGE DataKinds #-}
module Data.AST where
import Data.Range
import Data.Record
import Data.Span
import Data.Term
-- | An AST node labelled with symbols and source location.
type AST syntax grammar = Term syntax (Node grammar)
data Node grammar = Node
{ nodeSymbol :: !grammar
, nodeByteRange :: {-# UNPACK #-} !Range
, nodeSpan :: {-# UNPACK #-} !Span
}
deriving (Eq, Show)
-- | A location specified as possibly-empty intervals of bytes and line/column positions.
type Location = '[Range, Span]
nodeLocation :: Node grammar -> Record Location
nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil

41
src/Data/Algebra.hs Normal file
View File

@ -0,0 +1,41 @@
{-# LANGUAGE RankNTypes #-}
module Data.Algebra
( FAlgebra
, RAlgebra
, OpenFAlgebra
, OpenRAlgebra
, fToR
, fToOpenR
, rToOpenR
, openFToOpenR
) where
import Data.Functor.Foldable (Base)
-- | An F-algebra on some 'Recursive' type @t@.
type FAlgebra t a = Base t a -> a
-- | An R-algebra on some 'Recursive' type @t@.
type RAlgebra t a = Base t (t, a) -> a
-- | An open-recursive F-algebra on some 'Recursive' type @t@.
type OpenFAlgebra t a = forall b . (b -> a) -> Base t b -> a
-- | An open-recursive R-algebra on some 'Recursive' type @t@.
type OpenRAlgebra t a = forall b . (b -> (t, a)) -> Base t b -> a
-- | Promote an 'FAlgebra' into an 'RAlgebra' (by dropping the original parameter).
fToR :: Functor (Base t) => FAlgebra t a -> RAlgebra t a
fToR f = f . fmap snd
-- | Promote an 'FAlgebra' into an 'OpenRAlgebra' (by 'fmap'ing the action over the structure and dropping the original parameter).
fToOpenR :: Functor (Base t) => FAlgebra t a -> OpenRAlgebra t a
fToOpenR alg f = alg . fmap (snd . f)
-- | Promote an 'RAlgebra' into an 'OpenRAlgebra' (by 'fmap'ing the action over the structure).
rToOpenR :: Functor (Base t) => RAlgebra t a -> OpenRAlgebra t a
rToOpenR alg f = alg . fmap f
-- | Promote an 'OpenFAlgebra' into an 'OpenRAlgebra' (by dropping the original parameter).
openFToOpenR :: OpenFAlgebra t a -> OpenRAlgebra t a
openFToOpenR alg = alg . fmap snd

2
src/Data/Blob.hs
View File

@ -11,10 +11,10 @@ module Data.Blob
) where
import Data.ByteString.Char8 (ByteString, pack)
import Data.Language
import Data.Maybe (isJust)
import Data.Source as Source
import Data.Word
import Language
import Numeric
-- | The source, oid, path, and Maybe BlobKind of a blob.

6
src/Language.hs → src/Data/Language.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds, DeriveGeneric, DeriveAnyClass #-}
module Language where
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Data.Language where
import Data.Aeson
import GHC.Generics
@ -22,7 +22,7 @@ languageForType mediaType = case mediaType of
".json" -> Just JSON
".md" -> Just Markdown
".rb" -> Just Ruby
".go" -> Just Language.Go
".go" -> Just Go
".js" -> Just TypeScript
".ts" -> Just TypeScript
".tsx" -> Just TypeScript

4
src/Data/SplitDiff.hs
View File

@ -15,8 +15,8 @@ data SplitPatch a
-- | Get the range of a SplitDiff.
getRange :: Functor f => HasField fields Range => SplitDiff f (Record fields) -> Range
getRange diff = getField $ case diff of
Free annotated -> termAnnotation annotated
Pure patch -> extract (splitTerm patch)
Free annotated -> termFAnnotation annotated
Pure patch -> termAnnotation (splitTerm patch)
-- | A diff with only one side’s annotations.
type SplitDiff syntax ann = Free (TermF syntax ann) (SplitPatch (Term syntax ann))

15
src/Data/Syntax.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators #-}
module Data.Syntax where
import Algorithm hiding (Empty)
import qualified Assigning.Assignment as Assignment
import Control.Applicative
import Control.Monad.Error.Class hiding (Error)
import Data.Align.Generic
import Data.AST
import Data.ByteString (ByteString)
import qualified Data.Error as Error
import Data.Foldable (asum, toList)
@ -19,9 +20,9 @@ import Data.Range
import Data.Record
import Data.Semigroup
import Data.Span
import qualified Data.Syntax.Assignment as Assignment
import Data.Term
import Data.Union
import Diffing.Algorithm hiding (Empty)
import GHC.Generics
import GHC.Stack
@ -33,7 +34,7 @@ makeTerm a = makeTerm' a . inj
-- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
makeTerm' a f = termIn (sconcat (a :| (termAnnotation . unTerm <$> toList f))) f
makeTerm' a f = termIn (sconcat (a :| (termAnnotation <$> toList f))) f
-- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
@ -42,20 +43,20 @@ makeTerm1 = makeTerm1' . inj
-- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
makeTerm1' f = case toList f of
a : _ -> makeTerm' (termAnnotation (unTerm a)) f
a : _ -> makeTerm' (termAnnotation a) f
_ -> error "makeTerm1': empty structure"
-- | Construct an empty term at the current position.
emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Location))
emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil
-- | Catch assignment errors into an error term.
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Location))
handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
-- | Catch parse errors into an error term.
parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Assignment.Location))
parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Location))
parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack (getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])

123
src/Data/Syntax/Algebra.hs
View File

@ -1,123 +0,0 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
module Data.Syntax.Algebra
( FAlgebra
, RAlgebra
, fToR
, decoratorWithAlgebra
, identifierAlgebra
, cyclomaticComplexityAlgebra
, ConstructorName(..)
, ConstructorLabel(..)
, constructorNameAndConstantFields
, constructorLabel
) where
import Data.Aeson
import Data.Bifunctor (second)
import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.Functor.Classes (Show1 (liftShowsPrec))
import Data.Functor.Foldable
import Data.JSON.Fields
import Data.Record
import Data.Proxy
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Statement as Statement
import Data.Term
import Data.Text.Encoding (decodeUtf8)
import Data.Union
import GHC.Generics
-- | An F-algebra on some carrier functor 'f'.
type FAlgebra f a = f a -> a
-- | An R-algebra on some carrier functor 'f' of its fixpoint type 't'.
type RAlgebra f t a = f (t, a) -> a
-- | Promote an FAlgebra into an RAlgebra (by dropping the original parameter).
fToR :: Functor (Base t) => FAlgebra (Base t) a -> RAlgebra (Base t) t a
fToR f = f . fmap snd
-- | Lift an algebra into a decorator for terms annotated with records.
decoratorWithAlgebra :: Functor f
=> RAlgebra (Base (Term f (Record fs))) (Term f (Record fs)) a -- ^ An R-algebra on terms.
-> Term f (Record fs) -- ^ A term to decorate with values produced by the R-algebra.
-> Term f (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra.
decoratorWithAlgebra alg = para $ \ c@(In a f) -> termIn (alg (fmap (second (rhead . extract)) c) :. a) (fmap snd f)
newtype Identifier = Identifier ByteString
deriving (Eq, Show)
instance ToJSONFields Identifier where
toJSONFields (Identifier i) = [ "identifier" .= decodeUtf8 i ]
-- | Produce the identifier for a given term, if any.
--
-- Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not.
identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply Foldable fs, Apply Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier)
identifierAlgebra (In _ union) = case union of
_ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s)
_ | Just Declaration.Class{..} <- prj union -> classIdentifier
_ | Just Declaration.Method{..} <- prj union -> methodName
_ -> Nothing
-- | The cyclomatic complexity of a (sub)term.
newtype CyclomaticComplexity = CyclomaticComplexity Int
deriving (Enum, Eq, Num, Ord, Show)
-- | Compute the cyclomatic complexity of a (sub)term, measured as the number places where control exits scope, e.g. returns and yields.
--
-- TODO: Explicit returns at the end of methods should only count once.
-- TODO: Anonymous functions should not increase parent scope’s complexity.
-- TODO: Inner functions should not increase parent scope’s complexity.
cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply Foldable fs, Apply Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity
cyclomaticComplexityAlgebra (In _ union) = case union of
_ | Just Declaration.Method{} <- prj union -> succ (sum union)
_ | Just Statement.Return{} <- prj union -> succ (sum union)
_ | Just Statement.Yield{} <- prj union -> succ (sum union)
_ -> sum union
-- | Compute a 'ByteString' label for a 'Show1'able 'Term'.
--
-- This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that
-- constant fields will be included and parametric fields will not be.
constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString
constructorNameAndConstantFields (In _ f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")
-- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's.
constructorLabel :: Apply ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel
constructorLabel (In _ u) = ConstructorLabel $ pack (apply (Proxy :: Proxy ConstructorName) constructorName u)
newtype ConstructorLabel = ConstructorLabel ByteString
instance Show ConstructorLabel where
showsPrec _ (ConstructorLabel s) = showString (unpack s)
instance ToJSONFields ConstructorLabel where
toJSONFields (ConstructorLabel s) = [ "category" .= decodeUtf8 s ]
class ConstructorName f where
constructorName :: f a -> String
instance (Generic1 f, GConstructorName (Rep1 f)) => ConstructorName f where
constructorName = gconstructorName . from1
class GConstructorName f where
gconstructorName :: f a -> String
instance GConstructorName f => GConstructorName (M1 D c f) where
gconstructorName = gconstructorName . unM1
instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g) where
gconstructorName (L1 l) = gconstructorName l
gconstructorName (R1 r) = gconstructorName r
instance Constructor c => GConstructorName (M1 C c f) where
gconstructorName x = case conName x of
":" -> ""
n -> n

2
src/Data/Syntax/Comment.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Syntax.Comment where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic

2
src/Data/Syntax/Declaration.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Syntax.Declaration where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Ord.Generic

2
src/Data/Syntax/Expression.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Syntax.Expression where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Ord.Generic

2
src/Data/Syntax/Literal.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric #-}
module Data.Syntax.Literal where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic

2
src/Data/Syntax/Statement.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass, StandaloneDeriving #-}
module Data.Syntax.Statement where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Ord.Generic

2
src/Data/Syntax/Type.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Syntax.Type where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Ord.Generic

24
src/Data/Term.hs
View File

@ -2,17 +2,15 @@
module Data.Term
( Term(..)
, termIn
, termAnnotation
, termOut
, TermF(..)
, termSize
, extract
, unwrap
, hoistTerm
, hoistTermF
, stripTerm
) where
import Control.Comonad
import Control.Comonad.Cofree.Class
import Data.Aeson
import Data.Bifoldable
import Data.Bifunctor
@ -27,7 +25,14 @@ import Text.Show
-- | A Term with an abstract syntax tree and an annotation.
newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
data TermF syntax ann recur = In { termAnnotation :: ann, termOut :: syntax recur }
termAnnotation :: Term syntax ann -> ann
termAnnotation = termFAnnotation . unTerm
termOut :: Term syntax ann -> syntax (Term syntax ann)
termOut = termFOut . unTerm
data TermF syntax ann recur = In { termFAnnotation :: ann, termFOut :: syntax recur }
deriving (Eq, Foldable, Functor, Show, Traversable)
@ -57,11 +62,6 @@ type instance Base (Term f a) = TermF f a
instance Functor f => Recursive (Term f a) where project = unTerm
instance Functor f => Corecursive (Term f a) where embed = Term
instance Functor f => Comonad (Term f) where
extract = termAnnotation . unTerm
duplicate w = termIn w (fmap duplicate (unwrap w))
extend f = go where go w = termIn (f w) (fmap go (unwrap w))
instance Functor f => Functor (Term f) where
fmap f = go where go = Term . bimap f go . unTerm
@ -71,10 +71,6 @@ instance Foldable f => Foldable (Term f) where
instance Traversable f => Traversable (Term f) where
traverse f = go where go = fmap Term . bitraverse f go . unTerm
instance Functor f => ComonadCofree f (Term f) where
unwrap = termOut . unTerm
{-# INLINE unwrap #-}
instance Eq1 f => Eq1 (Term f) where
liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unTerm t1) (unTerm t2)

6
src/Algorithm.hs → src/Diffing/Algorithm.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds, DefaultSignatures, GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
module Algorithm where
module Diffing.Algorithm where
import Control.Applicative (Alternative(..))
import Control.Monad (guard)
@ -41,7 +41,7 @@ type Algorithm term1 term2 result = Freer (AlgorithmF term1 term2 result)
-- | Diff two terms without specifying the algorithm to be used.
diff :: term1 -> term2 -> Algorithm term1 term2 result result
diff a1 a2 = Algorithm.Diff a1 a2 `Then` return
diff a1 a2 = Diffing.Algorithm.Diff a1 a2 `Then` return
-- | Diff a These of terms without specifying the algorithm to be used.
diffThese :: These term1 term2 -> Algorithm term1 term2 result result
@ -77,7 +77,7 @@ byReplacing a1 a2 = Replace a1 a2 `Then` return
instance (Show term1, Show term2) => Show1 (AlgorithmF term1 term2 result) where
liftShowsPrec sp _ d algorithm = case algorithm of
Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2
Diffing.Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2
Linear t1 t2 -> showsBinaryWith showsPrec showsPrec "Linear" d t1 t2
RWS as bs -> showsBinaryWith (liftShowsPrec showsPrec showList) (liftShowsPrec showsPrec showList) "RWS" d as bs
Delete t1 -> showsUnaryWith showsPrec "Delete" d t1

20
src/RWS.hs → src/Diffing/Algorithm/RWS.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE GADTs, DataKinds, RankNTypes, TypeOperators #-}
module RWS
module Diffing.Algorithm.RWS
( rws
, Options(..)
, defaultOptions
@ -32,8 +32,8 @@ import Data.Semigroup hiding (First(..))
import Data.Term as Term
import Data.These
import Data.Traversable
import RWS.FeatureVector
import SES
import Diffing.Algorithm.RWS.FeatureVector
import Diffing.Algorithm.SES
type Label f fields label = forall b. TermF f (Record fields) b -> label
@ -89,7 +89,7 @@ rws canCompare equivalent as bs
--
-- cf §4.2 of RWS-Diff
mostSimilarMatching isEligible tree term = listToMaybe (sortOn (editDistanceUpTo optionsNodeComparisons term . snd) candidates)
where candidates = filter (uncurry isEligible) (snd <$> KdMap.kNearest tree optionsMaxSimilarTerms (rhead (extract term)))
where candidates = filter (uncurry isEligible) (snd <$> KdMap.kNearest tree optionsMaxSimilarTerms (rhead (termAnnotation term)))
data Options = Options
{ optionsLookaheadPlaces :: {-# UNPACK #-} !Int -- ^ How many places ahead should we look for similar terms?
@ -110,7 +110,7 @@ defaultQ = 3
toKdMap :: Functor syntax => [(Int, Term syntax (Record (FeatureVector ': fields)))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (Record (FeatureVector ': fields)))
toKdMap = KdMap.build unFV . fmap (rhead . extract . snd &&& id)
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.
data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }
@ -128,7 +128,7 @@ defaultFeatureVectorDecorator getLabel = featureVectorDecorator . pqGramDecorato
featureVectorDecorator :: (Foldable f, Functor f, Hashable label) => Term f (Record (Gram label ': fields)) -> Term f (Record (FeatureVector ': fields))
featureVectorDecorator = cata (\ (In (gram :. rest) functor) ->
termIn (foldl' addSubtermVector (unitVector (hash gram)) functor :. rest) functor)
where addSubtermVector v term = addVectors v (rhead (extract term))
where addSubtermVector v term = addVectors v (rhead (termAnnotation term))
-- | Annotates a term with the corresponding p,q-gram at each node.
pqGramDecorator
@ -141,7 +141,7 @@ pqGramDecorator
pqGramDecorator getLabel p q = cata algebra
where
algebra term = let label = getLabel term in
termIn (gram label :. termAnnotation term) (assignParentAndSiblingLabels (termOut term) label)
termIn (gram label :. termFAnnotation term) (assignParentAndSiblingLabels (termFOut term) label)
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))
@ -154,7 +154,7 @@ pqGramDecorator getLabel p q = cata algebra
put (drop 1 labels)
pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) functor
siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label]
siblingLabels = foldMap (base . rhead . extract)
siblingLabels = foldMap (base . rhead . termAnnotation)
padToSize n list = take n (list <> repeat empty)
-- | Test the comparability of two root 'Term's in O(1).
@ -164,7 +164,7 @@ canCompareTerms canCompare t1 t2 = canCompare (unTerm t1) (unTerm t2)
-- | Recursively test the equality of two 'Term's in O(n).
equalTerms :: Eq1 syntax => ComparabilityRelation syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Bool
equalTerms canCompare = go
where go a b = canCompareTerms canCompare a b && liftEq go (termOut (unTerm a)) (termOut (unTerm b))
where go a b = canCompareTerms canCompare a b && liftEq go (termOut a) (termOut b)
-- | Return an edit distance between two terms, up to a certain depth.
@ -176,7 +176,7 @@ editDistanceUpTo m a b = diffCost m (approximateDiff a b)
_ | m <= 0 -> 0
Merge body -> sum (fmap ($ pred m) body)
body -> succ (sum (fmap ($ pred m) body))
approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (Just . these deleting inserting approximateDiff) (unwrap a) (unwrap b))
approximateDiff a b = maybe (replacing a b) (merge (termAnnotation a, termAnnotation b)) (galignWith (Just . these deleting inserting approximateDiff) (termOut a) (termOut b))
-- Instances

2
src/RWS/FeatureVector.hs → src/Diffing/Algorithm/RWS/FeatureVector.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE BangPatterns, MagicHash #-}
module RWS.FeatureVector
module Diffing.Algorithm.RWS.FeatureVector
( FeatureVector
, unFV
, unitVector

2
src/SES.hs → src/Diffing/Algorithm/SES.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE BangPatterns, GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-}
module SES
module Diffing.Algorithm.SES
( EditScript
, ses
) where

10
src/Interpreter.hs → src/Diffing/Interpreter.hs
View File

@ -1,9 +1,9 @@
{-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
module Interpreter
module Diffing.Interpreter
( diffTerms
) where
import Algorithm
import Analysis.Decorator
import Control.Applicative (Alternative(..))
import Control.Monad.Free.Freer
import Data.Align.Generic
@ -11,9 +11,9 @@ import Data.Diff
import Data.Functor.Classes
import Data.Maybe (fromMaybe)
import Data.Record
import Data.Syntax.Algebra
import Data.Term
import RWS
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)
@ -34,7 +34,7 @@ runAlgorithm :: forall syntax fields1 fields2 m result
result
-> m result
runAlgorithm = iterFreerA (\ step yield -> case step of
Algorithm.Diff t1 t2 -> runAlgorithm (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield
Diffing.Algorithm.Diff t1 t2 -> runAlgorithm (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield
Linear (Term (In ann1 f1)) (Term (In ann2 f2)) -> merge (ann1, ann2) <$> galignWith (runAlgorithm . diffThese) f1 f2 >>= yield
RWS as bs -> traverse (runAlgorithm . diffThese) (rws comparableTerms equivalentTerms as bs) >>= yield
Delete a -> yield (deleting a)

4
src/Language/Go/Assignment.hs
View File

@ -6,13 +6,13 @@ module Language.Go.Assignment
, Term
) where
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Data.Functor (void)
import Data.List.NonEmpty (some1)
import Data.Record
import Data.Syntax (contextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm1)
import qualified Data.Syntax as Syntax
import Data.Syntax.Assignment hiding (Assignment, Error)
import qualified Data.Syntax.Assignment as Assignment
import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression

2
src/Language/Go/Syntax.hs
View File

@ -1,13 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
module Language.Go.Syntax where
import Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Ord.Generic
import Data.Functor.Classes.Show.Generic
import Data.Mergeable
import Diffing.Algorithm
import GHC.Generics

2
src/Language/Go/Type.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE DeriveAnyClass #-}
module Language.Go.Type where
import Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Ord.Generic
import Data.Functor.Classes.Show.Generic
import Data.Mergeable
import Diffing.Algorithm
import GHC.Generics
-- | A Bidirectional channel in Go (e.g. `chan`).

4
src/Language/JSON/Assignment.hs
View File

@ -6,11 +6,11 @@ module Language.JSON.Assignment
, Term)
where
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Data.Record
import Data.Syntax (makeTerm, parseError)
import qualified Data.Syntax as Syntax
import Data.Syntax.Assignment hiding (Assignment, Error)
import qualified Data.Syntax.Assignment as Assignment
import qualified Data.Syntax.Literal as Literal
import qualified Data.Term as Term
import Data.Union

18
src/Language/Markdown/Assignment.hs
View File

@ -6,20 +6,20 @@ module Language.Markdown.Assignment
, Language.Markdown.Assignment.Term
) where
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import qualified CMarkGFM
import Data.ByteString (ByteString)
import Data.Functor (void)
import Data.Record
import Data.Syntax (makeTerm)
import qualified Data.Syntax as Syntax
import Data.Syntax.Assignment hiding (Assignment, Error)
import qualified Data.Syntax.Assignment as Assignment
import Data.Term as Term (Term(..), TermF(..), termIn)
import Data.Term as Term (Term(..), TermF(..), termFAnnotation, termFOut, termIn)
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
import Data.Union
import GHC.Stack
import Language.Markdown as Grammar (Grammar(..))
import Parsing.CMark as Grammar (Grammar(..))
import qualified Language.Markdown.Syntax as Markup
type Syntax =
@ -77,19 +77,19 @@ paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> man
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) . termAnnotation . termOut <$> currentNode <*> children (many item))
CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . termFAnnotation . termFOut <$> currentNode <*> children (many item))
item :: Assignment
item = makeTerm <$> symbol Item <*> children (many blockElement)
heading :: Assignment
heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termAnnotation . termOut <$> currentNode <*> children (many inlineElement) <*> manyTill blockElement (void (symbol Heading) <|> eof))
heading = makeTerm <$> symbol Heading <*> ((\ (CMarkGFM.HEADING level) -> Markup.Heading level) . termFAnnotation . termFOut <$> currentNode <*> children (many inlineElement) <*> manyTill blockElement (void (symbol Heading) <|> eof))
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)) . termAnnotation . termOut <$> currentNode <*> source)
codeBlock = makeTerm <$> symbol CodeBlock <*> ((\ (CMarkGFM.CODE_BLOCK language _) -> Markup.Code (nullText language)) . termFAnnotation . termFOut <$> currentNode <*> source)
thematicBreak :: Assignment
thematicBreak = makeTerm <$> token ThematicBreak <*> pure Markup.ThematicBreak
@ -138,10 +138,10 @@ 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)) . termAnnotation . termOut <$> currentNode) <* advance
link = makeTerm <$> symbol Link <*> ((\ (CMarkGFM.LINK url title) -> Markup.Link (encodeUtf8 url) (nullText title)) . termFAnnotation . termFOut <$> currentNode) <* advance
image :: Assignment
image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termAnnotation . termOut <$> currentNode) <* advance
image = makeTerm <$> symbol Image <*> ((\ (CMarkGFM.IMAGE url title) -> Markup.Image (encodeUtf8 url) (nullText title)) . termFAnnotation . termFOut <$> currentNode) <* advance
code :: Assignment
code = makeTerm <$> symbol Code <*> (Markup.Code Nothing <$> source)

2
src/Language/Markdown/Syntax.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Language.Markdown.Syntax where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic

4
src/Language/Python/Assignment.hs
View File

@ -6,14 +6,14 @@ module Language.Python.Assignment
, Term
) where
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Data.Functor (void)
import Data.List.NonEmpty (some1)
import Data.Maybe (fromMaybe)
import Data.Record
import Data.Syntax (contextualize, emptyTerm, handleError, infixContext, makeTerm, makeTerm', makeTerm1, parseError, postContextualize)
import qualified Data.Syntax as Syntax
import Data.Syntax.Assignment hiding (Assignment, Error)
import qualified Data.Syntax.Assignment as Assignment
import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression

2
src/Language/Python/Syntax.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Language.Python.Syntax where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.Functor.Classes.Eq.Generic
import Data.Functor.Classes.Ord.Generic

4
src/Language/Ruby/Assignment.hs
View File

@ -6,14 +6,14 @@ module Language.Ruby.Assignment
, Term
) where
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Data.Maybe (fromMaybe)
import Data.Record
import Data.Functor (void)
import Data.List.NonEmpty (some1)
import Data.Syntax (contextualize, postContextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm1)
import qualified Data.Syntax as Syntax
import Data.Syntax.Assignment hiding (Assignment, Error)
import qualified Data.Syntax.Assignment as Assignment
import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression

4
src/Language/TypeScript/Assignment.hs
View File

@ -6,12 +6,12 @@ module Language.TypeScript.Assignment
, Term
) where
import Assigning.Assignment hiding (Assignment, Error)
import qualified Assigning.Assignment as Assignment
import Data.Maybe (fromMaybe, catMaybes)
import Data.Record
import Data.Syntax (emptyTerm, handleError, parseError, infixContext, makeTerm, makeTerm', makeTerm1, contextualize, postContextualize)
import qualified Data.Syntax as Syntax
import Data.Syntax.Assignment hiding (Assignment, Error)
import qualified Data.Syntax.Assignment as Assignment
import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression

2
src/Language/TypeScript/Syntax.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Language.TypeScript.Syntax where
import Algorithm
import Diffing.Algorithm
import Data.Align.Generic
import Data.ByteString (ByteString)
import Data.Functor.Classes.Eq.Generic

4
src/Language/Markdown.hs → src/Parsing/CMark.hs
View File

@ -1,17 +1,17 @@
{-# LANGUAGE DataKinds, TypeOperators #-}
module Language.Markdown
module Parsing.CMark
( Grammar(..)
, cmarkParser
, toGrammar
) where
import CMarkGFM
import qualified Data.AST as A
import Data.Ix
import Data.Range
import Data.Span
import Data.Source
import Data.Term
import qualified Data.Syntax.Assignment as A (AST, Node(..))
import TreeSitter.Language (Symbol(..), SymbolType(..))
data Grammar

39
src/Parser.hs → src/Parsing/Parser.hs
View File

@ -1,8 +1,10 @@
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
module Parser
module Parsing.Parser
( Parser(..)
, SomeParser(..)
, someParser
, ApplyAll
-- À la carte parsers
, goParser
, jsonParser
, markdownParser
@ -11,17 +13,18 @@ module Parser
, typescriptParser
) where
import Assigning.Assignment
import qualified CMarkGFM
import Data.AST
import Data.Functor.Classes (Eq1)
import Data.Kind
import Data.Ix
import Data.Kind
import Data.Language
import Data.Record
import qualified Data.Syntax as Syntax
import Data.Syntax.Assignment
import Data.Term
import Data.Union
import Foreign.Ptr
import Language
import qualified Language.Go.Assignment as Go
import qualified Language.JSON.Assignment as JSON
import qualified Language.Markdown.Assignment as Markdown
@ -48,31 +51,31 @@ data Parser term where
MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
-- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question.
type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (functors :: [* -> *]) :: Constraint where
ApplyAll (typeclass ': typeclasses) functors = (Apply typeclass functors, ApplyAll typeclasses functors)
ApplyAll '[] functors = ()
type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
ApplyAll (typeclass ': typeclasses) syntax = (typeclass syntax, ApplyAll typeclasses syntax)
ApplyAll '[] syntax = ()
-- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
--
-- This enables us to abstract over the details of the specific syntax types in cases where we can describe all the requirements on the syntax with a list of typeclasses.
data SomeParser typeclasses where
SomeParser :: ApplyAll typeclasses fs => { unSomeParser :: Parser (Term (Union fs) (Record Location)) } -> SomeParser typeclasses
data SomeParser typeclasses ann where
SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax ann) -> SomeParser typeclasses ann
-- | Construct a 'SomeParser' given a proxy for a list of typeclasses and the 'Language' to be parsed, all of which must be satisfied by all of the types in the syntaxes of our supported languages.
--
-- This can be used to perform operations uniformly over terms produced by blobs with different 'Language's, and which therefore have different types in general. For example, given some 'Blob', we can parse and 'show' the parsed & assigned 'Term' like so:
--
-- > case someParser (Proxy :: Proxy '[Show1]) <$> blobLanguage language of { Just (SomeParser parser) -> runTask (parse parser blob) >>= putStrLn . show ; _ -> return () }
someParser :: ( ApplyAll typeclasses Go.Syntax
, ApplyAll typeclasses JSON.Syntax
, ApplyAll typeclasses Markdown.Syntax
, ApplyAll typeclasses Python.Syntax
, ApplyAll typeclasses Ruby.Syntax
, ApplyAll typeclasses TypeScript.Syntax
someParser :: ( ApplyAll typeclasses (Union Go.Syntax)
, ApplyAll typeclasses (Union JSON.Syntax)
, ApplyAll typeclasses (Union Markdown.Syntax)
, ApplyAll typeclasses (Union Python.Syntax)
, ApplyAll typeclasses (Union Ruby.Syntax)
, ApplyAll typeclasses (Union TypeScript.Syntax)
)
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-> Language -- ^ The 'Language' to select.
-> SomeParser typeclasses -- ^ A 'SomeParser' abstracting the syntax type to be produced.
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-> Language -- ^ The 'Language' to select.
-> SomeParser typeclasses (Record Location) -- ^ A 'SomeParser' abstracting the syntax type to be produced.
someParser _ Go = SomeParser goParser
someParser _ JavaScript = SomeParser typescriptParser
someParser _ JSON = SomeParser jsonParser

10
src/TreeSitter.hs → src/Parsing/TreeSitter.hs
View File

@ -1,17 +1,17 @@
{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}
module TreeSitter
module Parsing.TreeSitter
( parseToAST
) where
import Control.Exception
import Control.Monad ((<=<))
import Data.AST (AST, Node(Node))
import Data.Blob
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Functor.Foldable hiding (Nil)
import Data.Range
import Data.Source
import Data.Span
import qualified Data.Syntax.Assignment as A
import Data.Term
import Foreign
import Foreign.Marshal.Array (allocaArray)
@ -20,7 +20,7 @@ import qualified TreeSitter.Node as TS
import qualified TreeSitter.Language as TS
-- | Parse 'Source' with the given 'TS.Language' and return its AST.
parseToAST :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Blob -> IO (A.AST [] grammar)
parseToAST :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Blob -> IO (AST [] grammar)
parseToAST language Blob{..} = bracket TS.ts_document_new TS.ts_document_free $ \ document -> do
TS.ts_document_set_language document language
root <- unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do
@ -32,13 +32,13 @@ parseToAST language Blob{..} = bracket TS.ts_document_new TS.ts_document_free $
anaM toAST root
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (A.AST [] grammar) TS.Node)
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
toAST node@TS.Node{..} = do
let count = fromIntegral nodeChildCount
children <- allocaArray count $ \ childNodesPtr -> do
_ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nullPtr nodePtr childNodesPtr (fromIntegral count))
peekArray count childNodesPtr
pure $! In (A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node)) children
pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node)) children
anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t
anaM g = a where a = pure . embed <=< traverse a <=< g

4
src/Renderer/JSON.hs → src/Rendering/JSON.hs
View File

@ -1,4 +1,4 @@
module Renderer.JSON
module Rendering.JSON
( renderJSONDiff
, renderJSONTerm
) where
@ -8,11 +8,11 @@ import Data.Aeson as A hiding (json)
import Data.Blob
import Data.Foldable (toList)
import Data.Functor.Both (Both)
import Data.Language
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import GHC.Generics
import Language
--
-- Diffs

12
src/Renderer.hs → src/Rendering/Renderer.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeOperators #-}
module Renderer
module Rendering.Renderer
( DiffRenderer(..)
, TermRenderer(..)
, SomeRenderer(..)
@ -10,8 +10,6 @@ module Renderer
, renderToCDiff
, renderToCTerm
, renderToTags
, HasDeclaration
, declarationAlgebra
, Summaries(..)
) where
@ -20,10 +18,10 @@ import Data.ByteString (ByteString)
import qualified Data.Map as Map
import Data.Output
import Data.Text (Text)
import Renderer.JSON as R
import Renderer.SExpression as R
import Renderer.Tag as R
import Renderer.TOC as R
import Rendering.JSON as R
import Rendering.SExpression as R
import Rendering.Tag as R
import Rendering.TOC as R
-- | Specification of renderers for diffs, producing output in the parameter type.
data DiffRenderer output where

2
src/Renderer/SExpression.hs → src/Rendering/SExpression.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
module Renderer.SExpression
module Rendering.SExpression
( renderSExpressionDiff
, renderSExpressionTerm
) where

192
src/Rendering/TOC.hs Normal file
View File

@ -0,0 +1,192 @@
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
module Rendering.TOC
( renderToCDiff
, renderToCTerm
, diffTOC
, Summaries(..)
, TOCSummary(..)
, isValidSummary
, getDeclaration
, declaration
, Entry(..)
, tableOfContentsBy
, termTableOfContentsBy
, dedupe
, entrySummary
, toCategoryName
) where
import Analysis.Declaration
import Data.Aeson
import Data.Align (bicrosswalk)
import Data.Bifoldable (bifoldMap)
import Data.Bifunctor (bimap)
import Data.Blob
import Data.ByteString.Lazy (toStrict)
import Data.Diff
import Data.Foldable (fold, foldl')
import Data.Functor.Both hiding (fst, snd)
import Data.Functor.Foldable (cata)
import Data.Function (on)
import Data.Language as Language
import Data.List (sortOn)
import qualified Data.List as List
import qualified Data.Map as Map hiding (null)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Output
import Data.Patch
import Data.Record
import Data.Semigroup ((<>))
import Data.Span
import Data.Term
import qualified Data.Text as T
import GHC.Generics
data Summaries = Summaries { changes, errors :: !(Map.Map T.Text [Value]) }
deriving (Eq, Show)
instance Monoid Summaries where
mempty = Summaries mempty mempty
mappend (Summaries c1 e1) (Summaries c2 e2) = Summaries (Map.unionWith (<>) c1 c2) (Map.unionWith (<>) e1 e2)
instance Output Summaries where
toOutput = toStrict . (<> "\n") . encode
instance ToJSON Summaries where
toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ]
data TOCSummary
= TOCSummary
{ summaryCategoryName :: T.Text
, summaryTermName :: T.Text
, summarySpan :: Span
, summaryChangeType :: T.Text
}
| ErrorSummary { error :: T.Text, errorSpan :: Span, errorLanguage :: Maybe Language }
deriving (Generic, Eq, Show)
instance ToJSON TOCSummary where
toJSON TOCSummary{..} = object [ "changeType" .= summaryChangeType, "category" .= summaryCategoryName, "term" .= summaryTermName, "span" .= summarySpan ]
toJSON ErrorSummary{..} = object [ "error" .= error, "span" .= errorSpan, "language" .= errorLanguage ]
isValidSummary :: TOCSummary -> Bool
isValidSummary ErrorSummary{} = False
isValidSummary _ = True
getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration
getDeclaration = getField
-- | Produce the annotations of nodes representing declarations.
declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields)
declaration (In annotation _) = annotation <$ getDeclaration annotation
-- | An entry in a table of contents.
data Entry a
= Changed { entryPayload :: a } -- ^ An entry for a node containing changes.
| Inserted { entryPayload :: a } -- ^ An entry for a change occurring inside an 'Insert' 'Patch'.
| Deleted { entryPayload :: a } -- ^ An entry for a change occurring inside a 'Delete' 'Patch'.
| Replaced { entryPayload :: a } -- ^ An entry for a change occurring on the insertion side of a 'Replace' 'Patch'.
deriving (Eq, Show)
-- | Compute a table of contents for a diff characterized by a function mapping relevant nodes onto values in Maybe.
tableOfContentsBy :: (Foldable f, Functor f)
=> (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe.
-> Diff f ann ann -- ^ The diff to compute the table of contents for.
-> [Entry a] -- ^ A list of entries for relevant changed nodes in the diff.
tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of
Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just []
Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of
(Just a, Just entries) -> Just (Changed a : entries)
(_ , entries) -> entries)
where patchEntry = patch Deleted Inserted (const Replaced)
termTableOfContentsBy :: (Foldable f, Functor f)
=> (forall b. TermF f annotation b -> Maybe a)
-> Term f annotation
-> [a]
termTableOfContentsBy selector = cata termAlgebra
where termAlgebra r | Just a <- selector r = a : fold r
| otherwise = fold r
newtype DedupeKey = DedupeKey (Maybe T.Text, Maybe T.Text) deriving (Eq, Ord)
-- Dedupe entries in a final pass. This catches two specific scenarios with
-- different behaviors:
-- 1. Identical entries are in the list.
-- Action: take the first one, drop all subsequent.
-- 2. Two similar entries (defined by a case insensitive comparision of their
-- identifiers) are in the list.
-- Action: Combine them into a single Replaced entry.
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)))
-> Entry (Record fields)
-> (Int, Map.Map DedupeKey (Int, Entry (Record fields)))
go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey x) m
= if exactMatch similar x
then (succ index, m)
else
let replacement = Replaced (entryPayload similar)
in (succ index, Map.insert (dedupeKey replacement) (index, replacement) m)
| otherwise = (succ index, Map.insert (dedupeKey x) (index, x) m)
dedupeKey entry = DedupeKey ((fmap toCategoryName . getDeclaration . entryPayload) entry, (fmap (T.toLower . declarationIdentifier) . getDeclaration . entryPayload) entry)
exactMatch = (==) `on` (getDeclaration . entryPayload)
-- | Construct a 'TOCSummary' from an 'Entry'.
entrySummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Entry (Record fields) -> Maybe TOCSummary
entrySummary entry = case entry of
Changed a -> recordSummary "modified" a
Deleted a -> recordSummary "removed" a
Inserted a -> recordSummary "added" a
Replaced a -> recordSummary "modified" a
-- | Construct a 'TOCSummary' from a node annotation and a change type label.
recordSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => T.Text -> Record fields -> Maybe TOCSummary
recordSummary changeText record = case getDeclaration record of
Just (ErrorDeclaration text _ language) -> Just $ ErrorSummary text (getField record) language
Just declaration -> Just $ TOCSummary (toCategoryName declaration) (formatIdentifier declaration) (getField record) changeText
Nothing -> Nothing
where
formatIdentifier (MethodDeclaration identifier _ (Just Language.Go) (Just receiver)) = "(" <> receiver <> ") " <> identifier
formatIdentifier (MethodDeclaration identifier _ _ (Just receiver)) = receiver <> "." <> identifier
formatIdentifier declaration = declarationIdentifier declaration
renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) (Record fields) -> Summaries
renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
where toMap [] = mempty
toMap as = Map.singleton summaryKey (toJSON <$> as)
summaryKey = T.pack $ case runJoin (blobPath <$> blobs) of
(before, after) | null before -> after
| null after -> before
| before == after -> after
| otherwise -> before <> " -> " <> after
diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) (Record fields) -> [TOCSummary]
diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration
renderToCTerm :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Blob -> Term f (Record fields) -> Summaries
renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
where
toMap [] = mempty
toMap as = Map.singleton (T.pack blobPath) (toJSON <$> as)
termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Term f (Record fields) -> [TOCSummary]
termToC = mapMaybe (recordSummary "unchanged") . termTableOfContentsBy declaration
-- The user-facing category name
toCategoryName :: Declaration -> T.Text
toCategoryName declaration = case declaration of
ClassDeclaration{} -> "Class"
FunctionDeclaration{} -> "Function"
MethodDeclaration{} -> "Method"
HeadingDeclaration _ _ _ l -> "Heading " <> T.pack (show l)
ErrorDeclaration{} -> "ParseError"

5
src/Renderer/Tag.hs → src/Rendering/Tag.hs
View File

@ -1,8 +1,9 @@
{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Renderer.Tag
module Rendering.Tag
( renderToTags
) where
import Analysis.Declaration
import Data.Aeson
import Data.Blob
import Data.Maybe (mapMaybe)
@ -11,7 +12,7 @@ import Data.Span
import Data.Term
import GHC.Generics
import qualified Data.Text as T
import Renderer.TOC
import Rendering.TOC
-- | Render a 'Term' to a ctags like output (See 'Tag').
renderToTags :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Blob -> Term f (Record fields) -> [Value]

72
src/Semantic.hs
View File

@ -7,27 +7,29 @@ module Semantic
, diffTermPair
) where
import Algorithm (Diffable)
import Analysis.ConstructorName (ConstructorName, constructorLabel)
import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Control.Exception
import Control.Monad ((<=<))
import Control.Monad ((>=>))
import Control.Monad.Error.Class
import Data.Align.Generic
import Data.Bifoldable
import Data.Blob
import Data.ByteString (ByteString)
import Data.Diff
import Data.Functor.Both as Both
import Data.Functor.Classes
import Data.JSON.Fields
import Data.Output
import Data.Bifoldable
import Data.Record
import Data.Syntax.Algebra
import Data.Term
import Data.Typeable
import Interpreter
import Parser
import Renderer
import Semantic.Task as Task
import Diffing.Algorithm (Diffable)
import Diffing.Interpreter
import Parsing.Parser
import Rendering.Renderer
import Semantic.Stat as Stat
import Semantic.Task as Task
-- This is the primary interface to the Semantic library which provides two
-- major classes of functionality: semantic parsing and diffing of source code
@ -43,24 +45,15 @@ parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . f
-- | A task to parse a 'Blob' and render the resulting 'Term'.
parseBlob :: TermRenderer output -> Blob -> Task output
parseBlob renderer blob@Blob{ blobLanguage = Just lang } = case renderer of
ToCTermRenderer
| SomeParser parser <- someParser (Proxy :: Proxy '[HasDeclaration, Foldable, Functor]) lang ->
parse parser blob >>= decorate (declarationAlgebra blob) >>= render (renderToCTerm blob)
parseBlob renderer blob@Blob{..}
| Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, HasDeclaration, Foldable, Functor, ToJSONFields1]) <$> blobLanguage
= parse parser blob >>= case renderer of
ToCTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToCTerm blob)
JSONTermRenderer -> decorate constructorLabel >=> render (renderJSONTerm blob)
SExpressionTermRenderer -> decorate constructorLabel . (Nil <$) >=> render renderSExpressionTerm
TagsTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)
JSONTermRenderer
| SomeParser parser <- someParser (Proxy :: Proxy '[ConstructorName, Foldable, Functor]) lang ->
parse parser blob >>= decorate constructorLabel >>= render (renderJSONTerm blob)
SExpressionTermRenderer
| SomeParser parser <- someParser (Proxy :: Proxy '[ConstructorName, Foldable, Functor]) lang ->
parse parser blob >>= decorate constructorLabel . (Nil <$) >>= render renderSExpressionTerm
TagsTermRenderer
| SomeParser parser <- someParser (Proxy :: Proxy '[HasDeclaration, Foldable, Functor]) lang ->
parse parser blob >>= decorate (declarationAlgebra blob) >>= render (renderToTags blob)
parseBlob _ Blob { blobPath = blobPath, blobLanguage = Nothing } = throwError (SomeException (NoLanguageForBlob blobPath))
| otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
data NoLanguageForBlob = NoLanguageForBlob FilePath
deriving (Eq, Exception, Ord, Show, Typeable)
@ -71,34 +64,31 @@ diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair rendere
-- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
diffBlobPair :: DiffRenderer output -> Both Blob -> Task output
diffBlobPair renderer blobs@(Join (Blob { blobLanguage = Just lang }, Blob { blobLanguage = Just _ })) = case renderer of
ToCDiffRenderer
| SomeParser parser <- someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, HasDeclaration, Show1, Traversable]) lang ->
run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms (renderToCDiff blobs)
diffBlobPair renderer blobs
| Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Show1, ToJSONFields1, Traversable]) <$> effectiveLanguage
= case renderer of
ToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms renderToCDiff
JSONDiffRenderer -> run ( parse parser) diffTerms renderJSONDiff
SExpressionDiffRenderer -> run ( parse parser >=> decorate constructorLabel . (Nil <$)) diffTerms (const renderSExpressionDiff)
JSONDiffRenderer
| SomeParser parser <- someParser (Proxy :: Proxy '[Diffable, Eq1, Foldable, Functor, GAlign, Show1, Traversable]) lang ->
run (parse parser) diffTerms (renderJSONDiff blobs)
| otherwise = throwError (SomeException (NoLanguageForBlob effectivePath))
where (effectivePath, effectiveLanguage) = case runJoin blobs of
(Blob { blobLanguage = Just lang, blobPath = path }, _) -> (path, Just lang)
(_, Blob { blobLanguage = Just lang, blobPath = path }) -> (path, Just lang)
(Blob { blobPath = path }, _) -> (path, Nothing)
SExpressionDiffRenderer
| SomeParser parser <- someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, Foldable, Functor, GAlign, Show1, Traversable]) lang ->
run (decorate constructorLabel . (Nil <$) <=< parse parser) diffTerms renderSExpressionDiff
where run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Diff syntax ann ann -> output) -> Task output
run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Both Blob -> Diff syntax ann ann -> output) -> Task output
run parse diff renderer = do
terms <- distributeFor blobs parse
time "diff" languageTag $ do
diff <- runBothWith (diffTermPair blobs diff) terms
writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
render renderer diff
render (renderer blobs) diff
where
showLanguage = pure . (,) "language" . show
languageTag = let (a, b) = runJoin blobs
in maybe (maybe [] showLanguage (blobLanguage b)) showLanguage (blobLanguage a)
diffBlobPair _ (Join (Blob { blobPath = path, blobLanguage = Nothing }, _)) = throwError (SomeException (NoLanguageForBlob path))
diffBlobPair _ (Join (_, Blob { blobPath = path, blobLanguage = Nothing })) = throwError (SomeException (NoLanguageForBlob path))
-- | A task to diff a pair of 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
diffTermPair :: Functor syntax => Both Blob -> Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
diffTermPair blobs differ t1 t2 = case runJoin (blobExists <$> blobs) of

10
src/SemanticCmdLine.hs → src/Semantic/CLI.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
module SemanticCmdLine
module Semantic.CLI
( main
-- Testing
, runDiff
@ -7,21 +7,21 @@ module SemanticCmdLine
) where
import Control.Monad ((<=<))
import Files (languageForFilePath)
import Data.ByteString (ByteString)
import Data.Foldable (find)
import Data.Functor.Both hiding (fst, snd)
import Data.Language
import Data.List (intercalate)
import Data.List.Split (splitWhen)
import Data.Semigroup ((<>))
import Data.Version (showVersion)
import Development.GitRev
import Language
import Options.Applicative hiding (action)
import Renderer
import Rendering.Renderer
import qualified Paths_semantic_diff as Library (version)
import qualified Semantic.Task as Task
import Semantic.IO (languageForFilePath)
import qualified Semantic.Log as Log
import qualified Semantic.Task as Task
import System.IO (Handle, stdin, stdout)
import qualified Semantic (parseBlobs, diffBlobPairs)
import Text.Read

6
src/Files.hs → src/Semantic/IO.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables, TupleSections #-}
module Files
module Semantic.IO
( readFile
, isDirectory
, readBlobPairsFromHandle
@ -14,6 +14,7 @@ import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Blob as Blob
import Data.Functor.Both
import Data.Language
import Data.Maybe
import Data.Semigroup
import Data.Source
@ -21,7 +22,6 @@ import Data.String
import Data.Text
import Data.These
import GHC.Generics
import Language
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Prelude hiding (readFile)
@ -60,7 +60,7 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle
where toBlobs BlobParse{..} = fmap toBlob blobs
readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob]
readBlobsFromPaths = traverse (uncurry Files.readFile)
readBlobsFromPaths = traverse (uncurry Semantic.IO.readFile)
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
readBlobsFromDir path = do

27
src/Semantic/Task.hs
View File

@ -25,12 +25,15 @@ module Semantic.Task
, runTaskWithOptions
) where
import Analysis.Decorator (decoratorWithAlgebra)
import qualified Assigning.Assignment as Assignment
import Control.Exception
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Control.Parallel.Strategies
import qualified Control.Concurrent.Async as Async
import Control.Monad.Free.Freer
import Data.Algebra (RAlgebra)
import Data.Blob
import Data.Bool
import qualified Data.ByteString as B
@ -39,19 +42,17 @@ import qualified Data.Error as Error
import Data.Foldable (fold, for_)
import Data.Functor.Both as Both hiding (snd)
import Data.Functor.Foldable (cata)
import Data.Language
import Data.Record
import qualified Data.Syntax as Syntax
import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra)
import qualified Data.Syntax.Assignment as Assignment
import Data.Term
import Data.Union
import qualified Files
import Language
import Language.Markdown
import Parser
import Parsing.Parser
import Parsing.CMark
import Parsing.TreeSitter
import System.Exit (die)
import System.IO (Handle, stderr)
import TreeSitter
import qualified Semantic.IO as IO
import Semantic.Log
import Semantic.Stat as Stat
import Semantic.Queue
@ -65,7 +66,7 @@ data TaskF output where
WriteStat :: Stat -> TaskF ()
Time :: String -> [(String, String)] -> Task output -> TaskF output
Parse :: Parser term -> Blob -> TaskF term
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
Decorate :: Functor f => RAlgebra (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> TaskF (Diff syntax ann1 ann2)
Render :: Renderer input output -> input -> TaskF output
Distribute :: Traversable t => t (Task output) -> TaskF (t output)
@ -115,7 +116,7 @@ parse :: Parser term -> Blob -> Task term
parse parser blob = Parse parser blob `Then` return
-- | A 'Task' which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
decorate :: Functor f => RAlgebra (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
decorate algebra term = Decorate algebra term `Then` return
-- | A 'Task' which diffs a pair of terms using the supplied 'Differ' function.
@ -175,10 +176,10 @@ runTaskWithOptions options task = do
where
go :: Task a -> IO (Either SomeException a)
go = iterFreerA (\ task yield -> case task of
ReadBlobs (Left handle) -> (Files.readBlobsFromHandle handle >>= yield) `catchError` (pure . Left . toException)
ReadBlobs (Right paths@[(path, Nothing)]) -> (Files.isDirectory path >>= bool (Files.readBlobsFromPaths paths) (Files.readBlobsFromDir path) >>= yield) `catchError` (pure . Left . toException)
ReadBlobs (Right paths) -> (Files.readBlobsFromPaths paths >>= yield) `catchError` (pure . Left . toException)
ReadBlobPairs source -> (either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield) `catchError` (pure . Left . toException)
ReadBlobs (Left handle) -> (IO.readBlobsFromHandle handle >>= yield) `catchError` (pure . Left . toException)
ReadBlobs (Right paths@[(path, Nothing)]) -> (IO.isDirectory path >>= bool (IO.readBlobsFromPaths paths) (IO.readBlobsFromDir path) >>= yield) `catchError` (pure . Left . toException)
ReadBlobs (Right paths) -> (IO.readBlobsFromPaths paths >>= yield) `catchError` (pure . Left . toException)
ReadBlobPairs source -> (either IO.readBlobPairsFromHandle (traverse (traverse (uncurry IO.readFile))) source >>= yield) `catchError` (pure . Left . toException)
WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
WriteLog level message pairs -> queueLogMessage logger level message pairs >>= yield
WriteStat stat -> queue statter stat >>= yield

26
src/Semantic/Util.hs
View File

@ -2,26 +2,26 @@
{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-}
module Semantic.Util where
import Analysis.Declaration
import Control.Monad.IO.Class
import Data.Blob
import Files
import Data.Record
import Data.Functor.Classes
import Algorithm
import Data.Align.Generic
import Interpreter
import Parser
import Data.Functor.Both
import Data.Term
import Data.Blob
import Data.Diff
import Semantic
import Semantic.Task
import Renderer.TOC
import Data.Functor.Both
import Data.Functor.Classes
import Data.Range
import Data.Record
import Data.Span
import Data.Term
import Diffing.Algorithm
import Diffing.Interpreter
import Parsing.Parser
import Semantic
import Semantic.IO as IO
import Semantic.Task
file :: MonadIO m => FilePath -> m Blob
file path = Files.readFile path (languageForFilePath path)
file path = IO.readFile path (languageForFilePath path)
diffWithParser :: (HasField fields Data.Span.Span,
HasField fields Range,

5
test/Data/Syntax/Assignment/Spec.hs → test/Assigning/Assignment/Spec.hs
View File

@ -1,6 +1,8 @@
{-# LANGUAGE DataKinds #-}
module Data.Syntax.Assignment.Spec where
module Assigning.Assignment.Spec where
import Assigning.Assignment
import Data.AST
import Data.Bifunctor (first)
import Data.ByteString.Char8 as B (ByteString, length, words)
import Data.Ix
@ -8,7 +10,6 @@ import Data.Range
import Data.Semigroup ((<>))
import Data.Source
import Data.Span
import Data.Syntax.Assignment
import Data.Term
import GHC.Stack (getCallStack)
import Prelude hiding (words)

2
test/DiffSpec.hs → test/Data/Diff/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds #-}
module DiffSpec where
module Data.Diff.Spec where
import Data.Diff
import Data.Functor.Listable (ListableSyntax)

6
test/Data/Functor/Listable.hs
View File

@ -27,12 +27,14 @@ module Data.Functor.Listable
, ListableSyntax
) where
import Analysis.Declaration
import Control.Monad.Free as Free
import Control.Monad.Trans.Free as FreeF
import Data.ByteString (ByteString)
import Data.Char (chr)
import Data.Diff
import Data.Functor.Both
import qualified Data.Language as Language
import Data.List.NonEmpty
import Data.Patch
import Data.Range
@ -49,10 +51,8 @@ import Data.Text as T (Text, pack)
import qualified Data.Text.Encoding as T
import Data.These
import Data.Union
import Renderer.TOC
import RWS
import Diffing.Algorithm.RWS
import Test.LeanCheck
import qualified Language
type Tier a = [a]

2
test/SourceSpec.hs → test/Data/Source/Spec.hs
View File

@ -1,4 +1,4 @@
module SourceSpec where
module Data.Source.Spec where
import Data.Char (chr)
import Data.Functor.Listable

2
test/TermSpec.hs → test/Data/Term/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds #-}
module TermSpec where
module Data.Term.Spec where
import Data.Functor.Listable
import Data.Term

10
test/Data/RandomWalkSimilarity/Spec.hs → test/Diffing/Algorithm/RWS/Spec.hs
View File

@ -1,19 +1,19 @@
{-# LANGUAGE DataKinds #-}
module Data.RandomWalkSimilarity.Spec where
module Diffing.Algorithm.RWS.Spec where
import Algorithm
import Analysis.Decorator
import Data.Array.IArray
import Data.Bifunctor
import Data.Diff
import Data.Functor.Listable (ListableSyntax)
import Data.Record
import qualified Data.Syntax as Syntax
import Data.Syntax.Algebra
import Data.Term
import Data.These
import Data.Union
import Interpreter
import RWS
import Diffing.Algorithm
import Diffing.Algorithm.RWS
import Diffing.Interpreter
import Test.Hspec
import Test.Hspec.LeanCheck

4
test/SES/Spec.hs → test/Diffing/Algorithm/SES/Spec.hs
View File

@ -1,7 +1,7 @@
module SES.Spec where
module Diffing.Algorithm.SES.Spec where
import Data.These
import SES
import Diffing.Algorithm.SES
import Test.Hspec
import Test.Hspec.LeanCheck

4
test/InterpreterSpec.hs → test/Diffing/Interpreter/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds #-}
module InterpreterSpec where
module Diffing.Interpreter.Spec where
import Data.Diff
import Data.Functor.Both
@ -9,7 +9,7 @@ import Data.Record
import qualified Data.Syntax as Syntax
import Data.Term
import Data.Union
import Interpreter
import Diffing.Interpreter
import Test.Hspec (Spec, describe, it, parallel)
import Test.Hspec.Expectations.Pretty
import Test.Hspec.LeanCheck

2
test/IntegrationSpec.hs → test/Integration/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, OverloadedStrings #-}
module IntegrationSpec where
module Integration.Spec where
import qualified Data.ByteString as B
import Data.Foldable (find, traverse_)

34
test/TOCSpec.hs → test/Rendering/TOC/Spec.hs
View File

@ -1,7 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DataKinds, TypeOperators #-}
module TOCSpec where
module Rendering.TOC.Spec where
import Analysis.Decorator (constructorNameAndConstantFields)
import Analysis.Declaration
import Data.Aeson
import Data.Bifunctor
import Data.Blob
@ -10,6 +11,7 @@ import Data.Diff
import Data.Functor.Both
import Data.Functor.Foldable (cata)
import Data.Functor.Listable
import Data.Language
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (Last(..))
import Data.Output
@ -19,7 +21,6 @@ import Data.Record
import Data.Semigroup ((<>))
import Data.Source
import Data.Span
import Data.Syntax.Algebra (constructorNameAndConstantFields)
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import Data.Term
@ -27,11 +28,11 @@ import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.These
import Data.Union
import Interpreter
import Language
import Diffing.Interpreter
import Parsing.Parser
import Prelude hiding (readFile)
import Renderer
import Renderer.TOC
import Rendering.Renderer
import Rendering.TOC
import Semantic
import Semantic.Task
import Semantic.Util
@ -40,7 +41,6 @@ import Test.Hspec (Spec, describe, it, parallel)
import Test.Hspec.Expectations.Pretty
import Test.Hspec.LeanCheck
import Test.LeanCheck
import Parser
spec :: Spec
spec = parallel $ do
@ -49,10 +49,10 @@ spec = parallel $ do
\ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff ListableSyntax () ()) `shouldBe` []
prop "produces no entries for identity diffs" $
\ term -> tableOfContentsBy (Just . termAnnotation) (diffTerms term (term :: Term ListableSyntax (Record '[Range, Span]))) `shouldBe` []
\ term -> tableOfContentsBy (Just . termFAnnotation) (diffTerms term (term :: Term ListableSyntax (Record '[Range, Span]))) `shouldBe` []
prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $
\ p -> tableOfContentsBy (Just . termAnnotation) (patch deleting inserting replacing p)
\ p -> tableOfContentsBy (Just . termFAnnotation) (patch deleting inserting replacing p)
`shouldBe`
patch (fmap Deleted) (fmap Inserted) (\ as bs -> Replaced (head bs) : fmap Deleted (tail as) <> fmap Inserted (tail bs)) (bimap (foldMap pure) (foldMap pure) (p :: Patch (Term ListableSyntax Int) (Term ListableSyntax Int)))
@ -224,17 +224,17 @@ emptyInfo = Range 0 0 :. Span (Pos 0 0) (Pos 0 0) :. Nil
-- Filter tiers for terms that we consider "meaniningful" in TOC summaries.
isMeaningfulTerm :: Term ListableSyntax a -> Bool
isMeaningfulTerm a
| Just (_:_) <- prj (termOut (unTerm a)) = False
| Just [] <- prj (termOut (unTerm a)) = False
| otherwise = True
| Just (_:_) <- prj (termOut a) = False
| Just [] <- prj (termOut a) = False
| otherwise = True
-- Filter tiers for terms if the Syntax is a Method or a Function.
isMethodOrFunction :: Term' -> Bool
isMethodOrFunction a
| Just Declaration.Method{} <- prj (termOut (unTerm a)) = True
| Just Declaration.Function{} <- prj (termOut (unTerm a)) = True
| any isJust (foldMap ((:[]) . rhead) a) = True
| otherwise = False
| Just Declaration.Method{} <- prj (termOut a) = True
| Just Declaration.Function{} <- prj (termOut a) = True
| any isJust (foldMap ((:[]) . rhead) a) = True
| otherwise = False
blobsForPaths :: Both FilePath -> IO (Both Blob)
blobsForPaths = traverse (readFile . ("test/fixtures/toc/" <>))

8
test/SemanticCmdLineSpec.hs → test/Semantic/CLI/Spec.hs
View File

@ -1,15 +1,15 @@
{-# LANGUAGE DuplicateRecordFields #-}
module SemanticCmdLineSpec where
module Semantic.CLI.Spec where
import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.Foldable (for_)
import Data.Functor.Both
import Data.Language
import Data.Semigroup ((<>))
import Language
import Renderer
import Rendering.Renderer
import Semantic.CLI
import Semantic.Task
import SemanticCmdLine
import System.IO (Handle)
import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
import Test.Hspec.Expectations.Pretty

6
test/CommandSpec.hs → test/Semantic/IO/Spec.hs
View File

@ -1,12 +1,12 @@
module CommandSpec where
module Semantic.IO.Spec where
import Files
import Data.Blob
import Data.Functor.Both as Both
import Data.Language
import Data.Maybe
import Data.String
import Language
import Prelude hiding (readFile)
import Semantic.IO
import System.Exit (ExitCode(..))
import System.IO (IOMode(..), openFile)
import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)

6
test/SemanticSpec.hs → test/Semantic/Spec.hs
View File

@ -1,13 +1,13 @@
module SemanticSpec where
module Semantic.Spec where
import Data.Blob
import Data.Diff
import Data.Functor (void)
import Data.Functor.Both as Both
import Data.Language
import Data.Patch
import Data.Term
import Language
import Renderer
import Rendering.Renderer
import Semantic
import Semantic.Task
import System.Exit

2
test/Semantic/StatSpec.hs → test/Semantic/Stat/Spec.hs
View File

@ -1,4 +1,4 @@
module Semantic.StatSpec where
module Semantic.Stat.Spec where
import Semantic.Stat
import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)

52
test/Spec.hs
View File

@ -1,37 +1,37 @@
module Main where
import qualified CommandSpec
import qualified Assigning.Assignment.Spec
import qualified Data.Diff.Spec
import qualified Data.Functor.Classes.Ord.Generic.Spec
import qualified Data.Mergeable.Spec
import qualified Data.RandomWalkSimilarity.Spec
import qualified Data.Syntax.Assignment.Spec
import qualified DiffSpec
import qualified InterpreterSpec
import qualified SES.Spec
import qualified SourceSpec
import qualified TermSpec
import qualified TOCSpec
import qualified IntegrationSpec
import qualified SemanticCmdLineSpec
import qualified SemanticSpec
import qualified Semantic.StatSpec
import qualified Data.Source.Spec
import qualified Data.Term.Spec
import qualified Diffing.Algorithm.RWS.Spec
import qualified Diffing.Algorithm.SES.Spec
import qualified Diffing.Interpreter.Spec
import qualified Integration.Spec
import qualified Rendering.TOC.Spec
import qualified Semantic.Spec
import qualified Semantic.CLI.Spec
import qualified Semantic.IO.Spec
import qualified Semantic.Stat.Spec
import Test.Hspec
main :: IO ()
main = hspec $ do
describe "Semantic.Stat" Semantic.StatSpec.spec
describe "Semantic.Stat" Semantic.Stat.Spec.spec
parallel $ do
describe "Command" CommandSpec.spec
describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
describe "Data.Diff" Data.Diff.Spec.spec
describe "Data.Functor.Classes.Ord.Generic" Data.Functor.Classes.Ord.Generic.Spec.spec
describe "Data.Mergeable" Data.Mergeable.Spec.spec
describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec
describe "Data.Syntax.Assignment" Data.Syntax.Assignment.Spec.spec
describe "Diff" DiffSpec.spec
describe "Interpreter" InterpreterSpec.spec
describe "SES" SES.Spec.spec
describe "Source" SourceSpec.spec
describe "Term" TermSpec.spec
describe "Semantic" SemanticSpec.spec
describe "SemanticCmdLine" SemanticCmdLineSpec.spec
describe "TOC" TOCSpec.spec
describe "Integration" IntegrationSpec.spec
describe "Data.Source" Data.Source.Spec.spec
describe "Data.Term" Data.Term.Spec.spec
describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec
describe "Diffing.Algorithm.SES" Diffing.Algorithm.SES.Spec.spec
describe "Diffing.Interpreter" Diffing.Interpreter.Spec.spec
describe "Rendering.TOC" Rendering.TOC.Spec.spec
describe "Semantic" Semantic.Spec.spec
describe "Semantic.CLI" Semantic.CLI.Spec.spec
describe "Semantic.IO" Semantic.IO.Spec.spec
describe "Integration" Integration.Spec.spec

4
test/SpecHelpers.hs
View File

@ -10,11 +10,11 @@ import Control.Exception
import Data.Blob
import qualified Data.ByteString as B
import Data.Functor.Both
import Data.Language
import Data.Maybe (fromMaybe)
import Data.Source
import Language
import Prelude hiding (readFile)
import Renderer
import Rendering.Renderer
import Semantic
import Semantic.Task
import System.FilePath