diff --git a/src/DiffSummary.hs b/src/DiffSummary.hs index 90b828b6c..1b2f67d9d 100644 --- a/src/DiffSummary.hs +++ b/src/DiffSummary.hs @@ -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