1
1
mirror of https://github.com/github/semantic.git synced 2024-12-23 23:11:50 +03:00
semantic/src/DiffSummary.hs

171 lines
9.6 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-}
2016-06-07 02:41:07 +03:00
2016-05-17 20:09:14 +03:00
module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..)) where
2016-04-25 18:46:10 +03:00
2016-06-28 23:38:06 +03:00
import Prologue hiding (snd, intercalate)
2016-04-25 18:46:10 +03:00
import Diff
import Info (Info, category)
2016-04-25 18:46:10 +03:00
import Patch
2016-05-17 22:59:07 +03:00
import Term
2016-04-25 18:46:10 +03:00
import Syntax
2016-05-16 20:19:30 +03:00
import Category
2016-05-03 19:17:38 +03:00
import Data.Functor.Foldable as Foldable
2016-05-18 00:34:27 +03:00
import Data.Functor.Both
import Data.OrderedMap
import Data.Record
2016-06-07 02:41:07 +03:00
import Data.Text as Text (intercalate, unpack)
2016-04-25 18:46:10 +03:00
2016-06-08 21:50:33 +03:00
data DiffInfo = DiffInfo { categoryName :: Text, termName :: Text } deriving (Eq, Show)
2016-05-18 17:18:26 +03:00
toTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Text
2016-06-14 23:50:34 +03:00
toTermName term = case unwrap term of
Fixed children -> fromMaybe "EmptyFixedNode" $ (toCategoryName . category) . extract <$> head children
2016-06-15 18:06:13 +03:00
Indexed children -> fromMaybe "EmptyIndexedNode" $ (toCategoryName . category) . extract <$> head children
Keyed children -> mconcat $ keys children
Leaf leaf -> toCategoryName leaf
2016-06-14 23:50:34 +03:00
Syntax.Assignment identifier value -> toTermName identifier <> toTermName value
2016-06-15 18:06:13 +03:00
Syntax.Function identifier _ _ -> (maybe "anonymous" toTermName identifier)
Syntax.FunctionCall i _ -> toTermName i
2016-06-14 23:50:34 +03:00
Syntax.MemberAccess base property -> case (unwrap base, unwrap property) of
(Syntax.FunctionCall{}, Syntax.FunctionCall{}) -> toTermName base <> "()." <> toTermName property <> "()"
(Syntax.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName property
(_, Syntax.FunctionCall{}) -> toTermName base <> "." <> toTermName property <> "()"
(_, _) -> toTermName base <> "." <> toTermName property
Syntax.MethodCall targetId methodId _ -> toTermName targetId <> sep <> toTermName methodId <> "()"
where sep = case unwrap targetId of
Syntax.FunctionCall{} -> "()."
_ -> "."
Syntax.SubscriptAccess base element -> case (unwrap base, unwrap element) of
(Syntax.FunctionCall{}, Syntax.FunctionCall{}) -> toTermName base <> "()." <> toTermName element <> "()"
(Syntax.FunctionCall{}, _) -> toTermName base <> "()." <> toTermName element
(_, Syntax.FunctionCall{}) -> toTermName base <> "[" <> toTermName element <> "()" <> "]"
(_, _) -> toTermName base <> "[" <> toTermName element <> "]"
Syntax.VarAssignment varId _ -> toTermName varId
2016-06-15 18:06:13 +03:00
Syntax.VarDecl decl -> toTermName decl
2016-06-16 01:51:17 +03:00
-- TODO: We should remove Args from Syntax since I don't think we should ever
2016-06-15 21:15:09 +03:00
-- evaluate Args as a single toTermName Text - joshvera
Syntax.Args args -> mconcat $ toTermName <$> args
2016-06-16 01:51:17 +03:00
-- TODO: We should remove Case from Syntax since I don't think we should ever
-- evaluate Case as a single toTermName Text - joshvera
Syntax.Case expr _ -> toTermName expr
2016-06-16 01:57:55 +03:00
Syntax.Switch expr _ -> toTermName expr
Syntax.Ternary expr _ -> toTermName expr
Syntax.MathAssignment id _ -> toTermName id
Syntax.Operator syntaxes -> mconcat $ toTermName <$> syntaxes
2016-07-11 19:55:32 +03:00
Syntax.Object kvs -> "{" <> intercalate ", " (toTermName <$> kvs) <> "}"
Syntax.Pair a b -> toTermName a <> ": " <> toTermName b
Comment a -> toCategoryName a
2016-05-24 19:49:16 +03:00
class HasCategory a where
toCategoryName :: a -> Text
2016-05-18 00:34:27 +03:00
2016-05-24 19:49:16 +03:00
instance HasCategory Text where
toCategoryName = identity
2016-05-18 19:01:16 +03:00
instance HasCategory Info where
toCategoryName = toCategoryName . category
2016-05-24 19:49:16 +03:00
instance HasCategory Category where
2016-06-10 22:24:37 +03:00
toCategoryName = \case
2016-06-15 18:06:13 +03:00
ArrayLiteral -> "array"
2016-05-18 00:34:27 +03:00
BinaryOperator -> "binary operator"
2016-06-16 17:54:20 +03:00
Boolean -> "boolean"
2016-05-18 20:37:02 +03:00
DictionaryLiteral -> "dictionary"
2016-06-15 18:06:13 +03:00
Error -> "error"
2016-06-10 22:24:37 +03:00
ExpressionStatements -> "expression statements"
2016-06-14 00:32:00 +03:00
Category.Assignment -> "assignment"
2016-06-15 18:06:13 +03:00
Category.Function -> "function"
Category.FunctionCall -> "function call"
Category.MemberAccess -> "member access"
2016-06-15 18:06:13 +03:00
Category.MethodCall -> "method call"
Category.Args -> "arguments"
Category.VarAssignment -> "var assignment"
2016-06-16 01:09:44 +03:00
Category.VarDecl -> "variable"
Category.Switch -> "switch statement"
Category.Case -> "case statement"
Category.SubscriptAccess -> "subscript access"
Category.MathAssignment -> "math assignment"
Category.Ternary -> "ternary"
Category.Operator -> "operator"
2016-06-15 18:06:13 +03:00
Identifier -> "identifier"
IntegerLiteral -> "integer"
Other s -> s
2016-07-08 18:17:46 +03:00
Category.Pair -> "pair"
2016-06-15 18:06:13 +03:00
Params -> "params"
Program -> "top level"
Regex -> "regex"
2016-06-15 18:06:13 +03:00
StringLiteral -> "string"
SymbolLiteral -> "symbol"
2016-06-15 18:39:18 +03:00
TemplateString -> "template string"
2016-06-28 23:38:06 +03:00
Category.Object -> "object"
2016-05-17 20:09:14 +03:00
2016-05-24 19:49:16 +03:00
instance HasCategory leaf => HasCategory (Term leaf Info) where
toCategoryName = toCategoryName . category . extract
2016-05-24 19:49:16 +03:00
2016-05-17 20:09:14 +03:00
data DiffSummary a = DiffSummary {
patch :: Patch a,
parentAnnotations :: [Category]
2016-05-17 20:09:14 +03:00
} deriving (Eq, Functor)
2016-05-13 18:44:03 +03:00
instance Show (DiffSummary DiffInfo) where
showsPrec _ DiffSummary{..} s = (++s) . unpack $ case patch of
(Insert diffInfo) -> "Added the " <> "'" <> termName diffInfo <> "' " <> categoryName diffInfo <> maybeParentContext parentAnnotations
(Delete diffInfo) -> "Deleted the " <> "'" <> termName diffInfo <> "' " <> categoryName diffInfo <> maybeParentContext parentAnnotations
(Replace t1 t2) ->
"Replaced the " <> "'" <> termName t1 <> "' " <> categoryName t1
<> " with the " <> "'" <> termName t2 <> "' " <> categoryName t2
<> maybeParentContext parentAnnotations
where maybeParentContext parentAnnotations = if null parentAnnotations
then ""
else " in the " <> intercalate "/" (toCategoryName <$> parentAnnotations) <> " context"
2016-04-25 18:46:10 +03:00
2016-05-24 19:49:16 +03:00
diffSummary :: HasCategory leaf => Diff leaf Info -> [DiffSummary DiffInfo]
2016-06-06 21:45:45 +03:00
diffSummary = cata $ \case
-- Skip comments and leaves since they don't have any changes
(Free (_ :< Leaf _)) -> []
Free (_ :< (Syntax.Comment _)) -> []
(Free (infos :< Indexed children)) -> prependSummary (category $ snd infos) <$> join children
(Free (infos :< Fixed children)) -> prependSummary (category $ snd infos) <$> join children
(Free (infos :< Keyed children)) -> prependSummary (category $ snd infos) <$> join (Prologue.toList children)
(Free (infos :< Syntax.FunctionCall identifier children)) -> prependSummary (category $ snd infos) <$> join (Prologue.toList (identifier : children))
2016-06-10 22:10:37 +03:00
(Free (infos :< Syntax.Function id ps body)) -> prependSummary (category $ snd infos) <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body
2016-06-14 00:32:00 +03:00
(Free (infos :< Syntax.Assignment id value)) -> prependSummary (category $ snd infos) <$> id <> value
(Free (infos :< Syntax.MemberAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property
(Free (infos :< Syntax.SubscriptAccess base property)) -> prependSummary (category $ snd infos) <$> base <> property
2016-06-13 00:26:31 +03:00
(Free (infos :< Syntax.MethodCall targetId methodId ps)) -> prependSummary (category $ snd infos) <$> targetId <> methodId <> ps
(Free (infos :< Syntax.VarAssignment varId value)) -> prependSummary (category $ snd infos) <$> varId <> value
(Free (infos :< Syntax.VarDecl decl)) -> prependSummary (category $ snd infos) <$> decl
(Free (infos :< Syntax.Args args)) -> prependSummary (category $ snd infos) <$> join args
2016-06-16 02:52:05 +03:00
(Free (infos :< Syntax.Switch expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases
(Free (infos :< Syntax.Case expr body)) -> prependSummary (category $ snd infos) <$> expr <> body
Free (infos :< (Syntax.Ternary expr cases)) -> prependSummary (category $ snd infos) <$> expr <> join cases
Free (infos :< (Syntax.MathAssignment id value)) -> prependSummary (category $ snd infos) <$> id <> value
Free (infos :< (Syntax.Operator syntaxes)) -> prependSummary (category $ snd infos) <$> join syntaxes
Free (infos :< (Syntax.Object kvs)) -> prependSummary (category $ snd infos) <$> join kvs
Free (infos :< (Syntax.Pair a b)) -> prependSummary (category $ snd infos) <$> a <> b
Free (infos :< (Syntax.Commented cs leaf)) -> prependSummary (category $ snd infos) <$> join cs <> fromMaybe [] leaf
(Pure (Insert term)) -> (\info -> DiffSummary (Insert info) []) <$> termToDiffInfo term
(Pure (Delete term)) -> (\info -> DiffSummary (Delete info) []) <$> termToDiffInfo term
(Pure (Replace t1 t2)) -> (\(info1, info2) -> DiffSummary (Replace info1 info2) []) <$> zip (termToDiffInfo t1) (termToDiffInfo t2)
termToDiffInfo :: HasCategory leaf => Term leaf Info -> [DiffInfo]
termToDiffInfo term = case runCofree term of
(_ :< Leaf _) -> [ DiffInfo (toCategoryName term) (toTermName term) ]
(_ :< Indexed children) -> join $ termToDiffInfo <$> children
(_ :< Fixed children) -> join $ termToDiffInfo <$> children
(_ :< Keyed children) -> join $ termToDiffInfo <$> Prologue.toList children
(info :< Syntax.FunctionCall identifier _) -> [ DiffInfo (toCategoryName info) (toTermName identifier) ]
(info :< Syntax.Ternary ternaryCondition _) -> [ DiffInfo (toCategoryName info) (toTermName ternaryCondition) ]
2016-06-13 00:32:03 +03:00
(info :< Syntax.Function identifier _ _) -> [ DiffInfo (toCategoryName info) (maybe "anonymous" toTermName identifier) ]
2016-06-15 03:48:04 +03:00
(info :< Syntax.Assignment identifier _) -> [ DiffInfo (toCategoryName info) (toTermName identifier) ]
(info :< Syntax.MathAssignment identifier _) -> [ DiffInfo (toCategoryName info) (toTermName identifier) ]
-- Currently we cannot express the operator for an operator production from TreeSitter. Eventually we should be able to
-- use the term name of the operator identifier when we have that production value. Until then, I'm using a placeholder value
-- to indicate where that value should be when constructing DiffInfos.
(info :< Syntax.Operator _) -> [DiffInfo (toCategoryName info) "x"]
(info :< Commented cs leaf) -> join (termToDiffInfo <$> cs) <> maybe [] (\leaf -> [ DiffInfo (toCategoryName info) (toTermName leaf) ]) leaf
(info :< _) -> [ DiffInfo (toCategoryName info) (toTermName term) ]
2016-05-16 17:54:05 +03:00
prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo
2016-05-16 17:54:05 +03:00
prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary }