Abstract actions over terms

semantic-python/test/Instances.hs

@@ -35,7 +35,7 @@ instance ToJSON1 Named where
   -- The correct thing to do here is to manually munge the bytestring
   -- together as a builder, but we don't even hit this code path,
   -- so it will do for now.
-  liftToEncoding f _ (Named _name a) = f a
+  liftToEncoding f _ (Named _ a) = f a
 
 instance ToJSON2 Incr where
   liftToJSON2 f _ g _ = \case

src/Control/Carrier/Parse/Measured.hs

@@ -75,7 +75,6 @@ runParser blob@Blob{..} parser = case parser of
     time "parse.cmark_parse" languageTag $
       let term = cmarkParser blobSource
       in length term `seq` pure term
-  SomeParser parser -> SomeTerm <$> runParser blob parser
   where languageTag = [("language" :: String, show (blobLanguage blob))]
 
 data ParserCancelled = ParserTimedOut | AssignmentTimedOut

src/Control/Carrier/Parse/Simple.hs

@@ -65,7 +65,6 @@ runParser timeout blob@Blob{..} parser = case parser of
   MarkdownParser ->
     let term = cmarkParser blobSource
     in length term `seq` pure term
-  SomeParser parser -> SomeTerm <$> runParser timeout blob parser
 
 data ParseFailure = ParseFailure String
   deriving (Show, Typeable)

src/Diffing/Algorithm/RWS.hs

@@ -30,11 +30,11 @@ import Prologue
 type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
 
 rws :: (Foldable syntax, Functor syntax, Diffable syntax)
-    => ComparabilityRelation syntax (FeatureVector, ann) (FeatureVector, ann)
-    -> (Term syntax (FeatureVector, ann) -> Term syntax (FeatureVector, ann) -> Bool)
-    -> [Term syntax (FeatureVector, ann)]
-    -> [Term syntax (FeatureVector, ann)]
-    -> EditScript (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann))
+    => ComparabilityRelation syntax (FeatureVector, ann1) (FeatureVector, ann2)
+    -> (Term syntax (FeatureVector, ann1) -> Term syntax (FeatureVector, ann2) -> Bool)
+    -> [Term syntax (FeatureVector, ann1)]
+    -> [Term syntax (FeatureVector, ann2)]
+    -> EditScript (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))
 rws _          _          as [] = This <$> as
 rws _          _          [] bs = That <$> bs
 rws canCompare _          [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a]

src/Diffing/Interpreter.hs

@@ -1,7 +1,7 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 module Diffing.Interpreter
 ( diffTerms
-, diffTermPair
+, DiffTerms(..)
 , stripDiff
 ) where
 
@@ -16,30 +16,33 @@ import Prologue
 
 -- | Diff two à la carte terms recursively.
 diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
-          => Term syntax ann
-          -> Term syntax ann
-          -> Diff.Diff syntax ann ann
+          => Term syntax ann1
+          -> Term syntax ann2
+          -> Diff.Diff syntax ann1 ann2
 diffTerms t1 t2 = stripDiff (fromMaybe (Diff.replacing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2')))))
   where (t1', t2') = ( defaultFeatureVectorDecorator t1
                      , defaultFeatureVectorDecorator t2)
 
 -- | Strips the head annotation off a diff annotated with non-empty records.
 stripDiff :: Functor syntax
-          => Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)
-          -> Diff.Diff syntax ann ann
+          => Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)
+          -> Diff.Diff syntax ann1 ann2
 stripDiff = bimap snd snd
 
--- | Diff a 'These' of terms.
-diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Diff.Diff syntax ann ann
-diffTermPair = these Diff.deleting Diff.inserting diffTerms
+class DiffTerms term diff | diff -> term, term -> diff where
+  -- | Diff a 'These' of terms.
+  diffTermPair :: These (term ann1) (term ann2) -> diff ann1 ann2
+
+instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) (Diff.Diff syntax) where
+  diffTermPair = these Diff.deleting Diff.inserting diffTerms
 
 
 -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
 runDiff :: Algorithm
-             (Term syntax (FeatureVector, ann))
-             (Term syntax (FeatureVector, ann))
-             (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann))
-             (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m)
+             (Term syntax (FeatureVector, ann1))
+             (Term syntax (FeatureVector, ann2))
+             (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2))
+             (DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m)
              result
         -> m result
 runDiff = runDiffC . runAlgorithm
@@ -57,8 +60,8 @@ instance ( Alternative m
          , Traversable syntax
          )
       => Carrier
-        (Diff (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) :+: sig)
-        (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) where
+        (Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig)
+        (DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m) where
   eff (L op) = case op of
     Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k
     Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k

src/Parsing/Parser.hs

@@ -1,8 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 module Parsing.Parser
 ( Parser(..)
-, SomeTerm(..)
-, withSomeTerm
 , SomeAnalysisParser(..)
 , SomeASTParser(..)
 , someASTParser
@@ -112,8 +110,7 @@ data Parser term where
                       -> Parser (Term (Sum syntaxes) Loc)
   -- | A parser for 'Markdown' using cmark.
   MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
-  -- | An abstraction over parsers when we don’t know the details of the term type.
-  SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax ann) -> Parser (SomeTerm typeclasses ann)
+
 
 -- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question.
 type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
@@ -168,12 +165,6 @@ precisePythonParser :: Parser (Py.Term Loc)
 precisePythonParser = UnmarshalParser tree_sitter_python
 
 
-data SomeTerm typeclasses ann where
-  SomeTerm :: ApplyAll typeclasses syntax => Term syntax ann -> SomeTerm typeclasses ann
-
-withSomeTerm :: (forall syntax . ApplyAll typeclasses syntax => Term syntax ann -> a) -> SomeTerm typeclasses ann -> a
-withSomeTerm with (SomeTerm term) = with term
-
 -- | A parser for producing specialized (tree-sitter) ASTs.
 data SomeASTParser where
   SomeASTParser :: (Bounded grammar, Enum grammar, Show grammar)

src/Rendering/TOC.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables #-}
 module Rendering.TOC
 ( renderToCDiff
-, renderToCTerm
 , diffTOC
 , Summaries(..)
 , TOCSummary(..)
@@ -143,15 +142,6 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV
 diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary]
 diffTOC = fmap entrySummary . dedupe . tableOfContentsBy declaration
 
-renderToCTerm :: (Foldable f, Functor f) => Blob -> Term f (Maybe Declaration) -> Summaries
-renderToCTerm b@Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
-  where
-    toMap [] = mempty
-    toMap as = Map.singleton (T.pack (blobPath b)) (toJSON <$> as)
-
-    termToC :: (Foldable f, Functor f) => Term f (Maybe Declaration) -> [TOCSummary]
-    termToC = fmap (recordSummary "unchanged") . termTableOfContentsBy declaration
-
 -- The user-facing category name
 toCategoryName :: Declaration -> T.Text
 toCategoryName declaration = case declaration of