1
1
mirror of https://github.com/github/semantic.git synced 2024-12-23 14:54:16 +03:00
semantic/src/DiffSummary.hs
2016-06-28 16:38:06 -04:00

172 lines
10 KiB
Haskell

{-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables #-}
module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..)) where
import Prologue hiding (snd, intercalate)
import Diff
import Info (Info, category)
import Patch
import Term
import Syntax
import Category
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
import Data.OrderedMap
import Data.Text as Text (intercalate, unpack)
data DiffInfo = DiffInfo { categoryName :: Text, termName :: Text } deriving (Eq, Show)
toTermName :: HasCategory leaf => Term leaf Info -> Text
toTermName term = case unwrap term of
Fixed children -> fromMaybe "EmptyFixedNode" $ (toCategoryName . category) . extract <$> head children
Indexed children -> fromMaybe "EmptyIndexedNode" $ (toCategoryName . category) . extract <$> head children
Keyed children -> mconcat $ keys children
Leaf leaf -> toCategoryName leaf
Syntax.Assignment identifier value -> toTermName identifier <> toTermName value
Syntax.Function identifier _ _ -> (maybe "anonymous" toTermName identifier)
Syntax.FunctionCall i _ -> toTermName i
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
Syntax.VarDecl decl -> toTermName decl
-- TODO: We should remove Args from Syntax since I don't think we should ever
-- evaluate Args as a single toTermName Text - joshvera
Syntax.Args args -> mconcat $ toTermName <$> args
-- 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
Syntax.Switch expr _ -> toTermName expr
Syntax.Ternary expr _ -> toTermName expr
Syntax.MathAssignment id _ -> toTermName id
Syntax.Operator syntaxes -> mconcat $ toTermName <$> syntaxes
Syntax.Object kvs -> mconcat $ toTermName . Prologue.fst <$> kvs
class HasCategory a where
toCategoryName :: a -> Text
instance HasCategory Text where
toCategoryName = identity
instance HasCategory Info where
toCategoryName = toCategoryName . category
instance HasCategory Category where
toCategoryName = \case
ArrayLiteral -> "array"
BinaryOperator -> "binary operator"
Boolean -> "boolean"
DictionaryLiteral -> "dictionary"
Error -> "error"
ExpressionStatements -> "expression statements"
Category.Assignment -> "assignment"
Category.Function -> "function"
Category.FunctionCall -> "function call"
Category.MemberAccess -> "member access"
Category.MethodCall -> "method call"
Category.Args -> "arguments"
Category.VarAssignment -> "var assignment"
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"
Identifier -> "identifier"
IntegerLiteral -> "integer"
Other s -> s
Pair -> "pair"
Params -> "params"
Program -> "top level"
Regex -> "regex"
StringLiteral -> "string"
SymbolLiteral -> "symbol"
TemplateString -> "template string"
Category.Object -> "object"
instance HasCategory leaf => HasCategory (Term leaf Info) where
toCategoryName = toCategoryName . category . extract
data DiffSummary a = DiffSummary {
patch :: Patch a,
parentAnnotations :: [Category]
} deriving (Eq, Functor)
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"
diffSummary :: HasCategory leaf => Diff leaf Info -> [DiffSummary DiffInfo]
diffSummary = cata $ \case
(Free (_ :< Leaf _)) -> [] -- Skip leaves since they don't have any changes
(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))
(Free (infos :< Syntax.Function id ps body)) -> prependSummary (category $ snd infos) <$> (fromMaybe [] id) <> (fromMaybe [] ps) <> body
(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
(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
(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
(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) ]
(info :< Syntax.Function identifier _ _) -> [ DiffInfo (toCategoryName info) (maybe "anonymous" toTermName identifier) ]
(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"]
memberAccess@(info :< Syntax.MemberAccess{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree memberAccess) ]
subscriptAccess@(info :< Syntax.SubscriptAccess{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree subscriptAccess) ]
methodCall@(info :< Syntax.MethodCall{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree methodCall) ]
-- TODO: We should remove Args from Syntax since I don't think we shouldn ever
-- evaluate Args as a single toTermName Text - joshvera
args@(info :< Syntax.Args{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree args) ]
varDecl@(info :< Syntax.VarDecl{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree varDecl) ]
varAssignment@(info :< Syntax.VarAssignment{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree varAssignment) ]
switch@(info :< Syntax.Switch{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree switch) ]
caseExpr@(info :< Syntax.Case{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree caseExpr) ]
object@(info :< Syntax.Object{}) -> [ DiffInfo (toCategoryName info) (toTermName $ cofree object) ]
prependSummary :: Category -> DiffSummary DiffInfo -> DiffSummary DiffInfo
prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary }