1
1
mirror of https://github.com/github/semantic.git synced 2024-12-22 22:31:36 +03:00

Prepend (Category, TermName) to DiffSummary.parentAnnotations

This commit is contained in:
joshvera 2016-08-08 14:06:07 -04:00
parent c191312ece
commit 51cb8918a9

View File

@ -2,7 +2,7 @@
module DiffSummary (DiffSummary(..), diffSummaries, DiffInfo(..), annotatedSummaries) where
import Prologue hiding (snd, intercalate)
import Prologue hiding (intercalate)
import Diff
import Patch
import Term
@ -11,7 +11,8 @@ import Range
import Syntax as S
import Category as C
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
import Data.Functor.Both hiding (fst, snd)
import qualified Data.Functor.Both as Both
import Data.Text as Text (intercalate)
import Test.QuickCheck hiding (Fixed)
import Patch.Arbitrary()
@ -27,55 +28,31 @@ data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text }
deriving (Eq, Show)
data Branch = BIndexed | BFixed | BCommented deriving (Show, Eq, Generic)
data DiffSummary a = DiffSummary {
patch :: Patch a,
parentAnnotations :: [Category]
parentAnnotations :: [(Category, Text)]
} deriving (Eq, Functor, Show, Generic)
annotatedSummaries :: DiffSummary DiffInfo -> [Text]
annotatedSummaries DiffSummary{..} = show . (P.<> maybeParentContext parentAnnotations) <$> summaries patch
diffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [DiffSummary DiffInfo]
diffSummaries sources = cata $ \case
-- Skip comments and leaves since they don't have any changes
(Free (_ :< Leaf _)) -> []
Free (_ :< (S.Comment _)) -> []
(Free (infos :< S.Indexed children)) -> annotateWithCategory infos <$> join children
(Free (infos :< S.Fixed children)) -> annotateWithCategory infos <$> join children
(Free (infos :< S.FunctionCall identifier children)) -> annotateWithCategory infos <$> join (Prologue.toList (identifier : children))
(Free (infos :< S.Function id ps body)) -> annotateWithCategory infos <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body
(Free (infos :< S.Assignment id value)) -> annotateWithCategory infos <$> id <> value
(Free (infos :< S.MemberAccess base property)) -> annotateWithCategory infos <$> base <> property
(Free (infos :< S.SubscriptAccess base property)) -> annotateWithCategory infos <$> base <> property
(Free (infos :< S.MethodCall targetId methodId ps)) -> annotateWithCategory infos <$> targetId <> methodId <> ps
(Free (infos :< S.VarAssignment varId value)) -> annotateWithCategory infos <$> varId <> value
(Free (infos :< S.VarDecl decl)) -> annotateWithCategory infos <$> decl
(Free (infos :< S.Args args)) -> annotateWithCategory infos <$> join args
(Free (infos :< S.Switch expr cases)) -> annotateWithCategory infos <$> expr <> join cases
(Free (infos :< S.Case expr body)) -> annotateWithCategory infos <$> expr <> body
Free (infos :< (S.Ternary expr cases)) -> annotateWithCategory infos <$> expr <> join cases
Free (infos :< (S.MathAssignment id value)) -> annotateWithCategory infos <$> id <> value
Free (infos :< (S.Operator syntaxes)) -> annotateWithCategory infos <$> join syntaxes
Free (infos :< (S.Object kvs)) -> annotateWithCategory infos <$> join kvs
Free (infos :< (S.Return expr)) -> annotateWithCategory infos <$> fromMaybe [] expr
Free (infos :< (S.Pair a b)) -> annotateWithCategory infos <$> a <> b
Free (infos :< (S.Commented cs leaf)) -> annotateWithCategory infos <$> join cs <> fromMaybe [] leaf
Free (infos :< (S.Error _ children)) -> annotateWithCategory infos <$> join children
(Free (infos :< S.For exprs body)) -> annotateWithCategory infos <$> join exprs <> body
(Free (infos :< S.While expr body)) -> annotateWithCategory infos <$> expr <> body
(Free (infos :< S.DoWhile expr body)) -> annotateWithCategory infos <$> expr <> body
(Free (infos :< S.Throw expr)) -> annotateWithCategory infos <$> expr
(Free (infos :< S.Constructor expr)) -> annotateWithCategory infos <$> expr
(Free (infos :< S.Try expr catch finally)) -> annotateWithCategory infos <$> expr <> fromMaybe [] catch <> fromMaybe [] finally
(Free (infos :< S.Array children)) -> annotateWithCategory infos <$> join children
(Free (infos :< S.Class identifier superclass definitions)) -> annotateWithCategory infos <$> identifier <> fromMaybe [] superclass <> join definitions
(Free (infos :< S.Method identifier params definitions)) -> annotateWithCategory infos <$> identifier <> join params <> join definitions
(Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ]
(Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ]
(Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ]
diffSummaries sources = para $ \diff ->
let diff' = free (Prologue.fst <$> diff)
annotateWithCategory :: [(Diff leaf (Record fields), [DiffSummary DiffInfo])] -> [DiffSummary DiffInfo]
annotateWithCategory children = maybeToList (prependSummary (Both.snd sources) <$> (afterTerm diff')) <*> (children >>= snd) in
case diff of
-- Skip comments and leaves since they don't have any changes
Free (_ :< Leaf _) -> []
Free (_ :< (S.Comment _)) -> []
(Free (_ :< syntax)) -> annotateWithCategory (toList syntax)
(Pure (Insert term)) -> [ DiffSummary (Insert $ termToDiffInfo afterSource term) [] ]
(Pure (Delete term)) -> [ DiffSummary (Delete $ termToDiffInfo beforeSource term) [] ]
(Pure (Replace t1 t2)) -> [ DiffSummary (Replace (termToDiffInfo beforeSource t1) (termToDiffInfo afterSource t2)) [] ]
where
(beforeSource, afterSource) = runJoin sources
annotateWithCategory infos = prependSummary (category $ snd infos)
summaries :: Patch DiffInfo -> [P.Doc]
summaries (Insert info) = (("Added" <+> "the") <+>) <$> toLeafInfos info
@ -142,10 +119,10 @@ toTermName source term = case unwrap term of
termNameFromRange range = toText $ Source.slice range source
range = characterRange . extract
maybeParentContext :: [Category] -> Doc
maybeParentContext annotations = if null annotations
then ""
else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context"
maybeParentContext :: [(Category, Text)] -> Doc
maybeParentContext annotations = case annotations of
[] -> ""
(annotation:xs) -> space <> "in the" <+> (toDoc $ snd annotation) <+> toDoc (toCategoryName $ fst annotation)
toDoc :: Text -> Doc
toDoc = string . toS
@ -168,8 +145,8 @@ termToDiffInfo blob term = case unwrap term of
where toTermName' = toTermName blob
termToDiffInfo' = termToDiffInfo blob
prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo
prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary }
prependSummary :: (HasCategory leaf, HasField fields Range, HasField fields Category) => Source Char -> Term leaf (Record fields) -> DiffSummary DiffInfo -> DiffSummary DiffInfo
prependSummary source term summary = summary { parentAnnotations = (category $ extract term, toTermName source term) : parentAnnotations summary }
-- The user-facing category name of 'a'.
class HasCategory a where