Prepend (Category, TermName) to DiffSummary.parentAnnotations

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
+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 (_ :< Leaf _) -> []
     Free (_ :< (S.Comment _)) -> []
-  (Free (infos :< S.Indexed children)) -> annotateWithCategory infos <$> join children
+    (Free (_ :< syntax)) -> annotateWithCategory (toList syntax)
-  (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)) [] ]
   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 :: [(Category, Text)] -> Doc
-maybeParentContext annotations = if null annotations
+maybeParentContext annotations = case annotations of
-  then ""
+  [] -> ""
-  else space <> "in the" <+> (toDoc . intercalate "/" $ toCategoryName <$> annotations) <+> "context"
+  (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 :: (HasCategory leaf, HasField fields Range, HasField fields Category) => Source Char -> Term leaf (Record fields) -> DiffSummary DiffInfo -> DiffSummary DiffInfo
-prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary }
+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