🔥 the Comonad & ComonadCofree instances for Term.

src/Data/Term.hs

@@ -6,15 +6,11 @@ module Data.Term
 , termOut
 , TermF(..)
 , termSize
-, extract
-, unwrap
 , hoistTerm
 , hoistTermF
 , stripTerm
 ) where
 
-import Control.Comonad
-import Control.Comonad.Cofree.Class
 import Data.Aeson
 import Data.Bifoldable
 import Data.Bifunctor
@@ -66,11 +62,6 @@ type instance Base (Term f a) = TermF f a
 instance Functor f => Recursive (Term f a) where project = unTerm
 instance Functor f => Corecursive (Term f a) where embed = Term
 
-instance Functor f => Comonad (Term f) where
-  extract = termAnnotation
-  duplicate w = termIn w (fmap duplicate (unwrap w))
-  extend f = go where go w = termIn (f w) (fmap go (unwrap w))
-
 instance Functor f => Functor (Term f) where
   fmap f = go where go = Term . bimap f go . unTerm
 
@@ -80,10 +71,6 @@ instance Foldable f => Foldable (Term f) where
 instance Traversable f => Traversable (Term f) where
   traverse f = go where go = fmap Term . bitraverse f go . unTerm
 
-instance Functor f => ComonadCofree f (Term f) where
-  unwrap = termOut
-  {-# INLINE unwrap #-}
-
 instance Eq1 f => Eq1 (Term f) where
   liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unTerm t1) (unTerm t2)
 

src/Decorator.hs

@@ -46,7 +46,7 @@ decoratorWithAlgebra :: Functor f
                      => RAlgebra (Term f (Record fs)) a -- ^ An R-algebra on terms.
                      -> Term f (Record fs) -- ^ A term to decorate with values produced by the R-algebra.
                      -> Term f (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra.
-decoratorWithAlgebra alg = para $ \ c@(In a f) -> termIn (alg (fmap (second (rhead . extract)) c) :. a) (fmap snd f)
+decoratorWithAlgebra alg = para $ \ c@(In a f) -> termIn (alg (fmap (second (rhead . termAnnotation)) c) :. a) (fmap snd f)
 
 
 newtype Identifier = Identifier ByteString
@@ -81,7 +81,7 @@ syntaxIdentifierAlgebra (In _ syntax) = case syntax of
   S.TypeDecl f _ -> identifier f
   S.VarAssignment f _ -> asum $ identifier <$> f
   _ -> Nothing
-  where identifier = fmap (Identifier . encodeUtf8) . S.extractLeafValue . unwrap . fst
+  where identifier = fmap (Identifier . encodeUtf8) . S.extractLeafValue . termOut . fst
 
 
 -- | The cyclomatic complexity of a (sub)term.

src/Language.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds, DeriveGeneric, DeriveAnyClass #-}
 module Language where
 
-import Control.Comonad.Trans.Cofree
 import Data.Aeson
 import Data.Foldable
 import Data.Record
@@ -37,30 +36,30 @@ languageForType mediaType = case mediaType of
     _ -> Nothing
 
 toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
-toVarDeclOrAssignment child = case unwrap child of
-  S.Indexed [child', assignment] -> termIn (setCategory (extract child) VarAssignment) (S.VarAssignment [child'] assignment)
-  S.Indexed [child'] -> termIn (setCategory (extract child) VarDecl) (S.VarDecl [child'])
-  S.VarDecl _ -> termIn (setCategory (extract child) VarDecl) (unwrap child)
+toVarDeclOrAssignment child = case termOut child of
+  S.Indexed [child', assignment] -> termIn (setCategory (termAnnotation child) VarAssignment) (S.VarAssignment [child'] assignment)
+  S.Indexed [child'] -> termIn (setCategory (termAnnotation child) VarDecl) (S.VarDecl [child'])
+  S.VarDecl _ -> termIn (setCategory (termAnnotation child) VarDecl) (termOut child)
   S.VarAssignment _ _ -> child
   _ -> toVarDecl child
 
 toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
-toVarDecl child = termIn (setCategory (extract child) VarDecl) (S.VarDecl [child])
+toVarDecl child = termIn (setCategory (termAnnotation child) VarDecl) (S.VarDecl [child])
 
 toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)]
-toTuple child | S.Indexed [key,value] <- unwrap child = [termIn (extract child) (S.Pair key value)]
-toTuple child | S.Fixed [key,value] <- unwrap child = [termIn (extract child) (S.Pair key value)]
-toTuple child | S.Leaf c <- unwrap child = [termIn (extract child) (S.Comment c)]
+toTuple child | S.Indexed [key,value] <- termOut child = [termIn (termAnnotation child) (S.Pair key value)]
+toTuple child | S.Fixed [key,value] <- termOut child = [termIn (termAnnotation child) (S.Pair key value)]
+toTuple child | S.Leaf c <- termOut child = [termIn (termAnnotation child) (S.Comment c)]
 toTuple child = pure child
 
 toPublicFieldDefinition :: HasField fields Category => [Term S.Syntax (Record fields)] -> Maybe (S.Syntax (Term S.Syntax (Record fields)))
-toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of
+toPublicFieldDefinition children = case break (\x -> category (termAnnotation x) == Identifier) children of
   (prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment
   (_, [_]) -> Just $ S.VarDecl children
   _ -> Nothing
 
 toInterface :: HasField fields Category => [Term S.Syntax (Record fields)] -> Maybe (S.Syntax (Term S.Syntax (Record fields)))
-toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of
-  (clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body))
+toInterface (id : rest) = case break (\x -> category (termAnnotation x) == Other "object_type") rest of
+  (clauses, [body]) -> Just $ S.Interface id clauses (toList (termOut body))
   _ -> Nothing
 toInterface _ = Nothing

src/Language/Go.hs

@@ -1,8 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 module Language.Go where
 
-import Control.Comonad
-import Control.Comonad.Cofree
 import Data.Foldable (toList)
 import Data.Maybe
 import Data.Record
@@ -20,17 +18,17 @@ termAssignment
 termAssignment source category children = case (category, children) of
   (Module, [moduleName]) -> Just $ S.Module moduleName []
   (Import, [importName]) -> Just $ S.Import importName []
-  (Function, [id, params, block]) -> Just $ S.Function id [params] (toList (unwrap block))
-  (Function, [id, params, ty, block]) -> Just $ S.Function id [params, ty] (toList (unwrap block))
-  (For, [body]) | Other "block" <- Info.category (extract body) -> Just $ S.For [] (toList (unwrap body))
-  (For, [forClause, body]) | Other "for_clause" <- Info.category (extract forClause) -> Just $ S.For (toList (unwrap forClause)) (toList (unwrap body))
-  (For, [rangeClause, body]) | Other "range_clause" <- Info.category (extract rangeClause) -> Just $ S.For (toList (unwrap rangeClause)) (toList (unwrap body))
+  (Function, [id, params, block]) -> Just $ S.Function id [params] (toList (termOut block))
+  (Function, [id, params, ty, block]) -> Just $ S.Function id [params, ty] (toList (termOut block))
+  (For, [body]) | Other "block" <- Info.category (termAnnotation body) -> Just $ S.For [] (toList (termOut body))
+  (For, [forClause, body]) | Other "for_clause" <- Info.category (termAnnotation forClause) -> Just $ S.For (toList (termOut forClause)) (toList (termOut body))
+  (For, [rangeClause, body]) | Other "range_clause" <- Info.category (termAnnotation rangeClause) -> Just $ S.For (toList (termOut rangeClause)) (toList (termOut body))
   (TypeDecl, [identifier, ty]) -> Just $ S.TypeDecl identifier ty
   (StructTy, _) -> Just (S.Ty children)
   (FieldDecl, _) -> Just (S.FieldDecl children)
   (ParameterDecl, param : ty) -> Just $ S.ParameterDecl (listToMaybe ty) param
   (Assignment, [identifier, expression]) -> Just $ S.VarAssignment [identifier] expression
-  (Select, _) -> Just $ S.Select (children >>= toList . unwrap)
+  (Select, _) -> Just $ S.Select (children >>= toList . termOut)
   (Go, [expr]) -> Just $ S.Go expr
   (Defer, [expr]) -> Just $ S.Defer expr
   (SubscriptAccess, [a, b]) -> Just $ S.SubscriptAccess a b
@@ -38,15 +36,15 @@ termAssignment source category children = case (category, children) of
   (Slice, [a, rest]) -> Just $ S.SubscriptAccess a rest
   (Literal, children) -> Just . S.Indexed $ unpackElement <$> children
   (Other "composite_literal", [ty, values])
-    | ArrayTy <- Info.category (extract ty)
-    -> Just $ S.Array (Just ty) (toList (unwrap values))
-    | DictionaryTy <- Info.category (extract ty)
-    -> Just $ S.Object (Just ty) (toList (unwrap values))
-    | SliceTy <- Info.category (extract ty)
+    | ArrayTy <- Info.category (termAnnotation ty)
+    -> Just $ S.Array (Just ty) (toList (termOut values))
+    | DictionaryTy <- Info.category (termAnnotation ty)
+    -> Just $ S.Object (Just ty) (toList (termOut values))
+    | SliceTy <- Info.category (termAnnotation ty)
     -> Just $ S.SubscriptAccess ty values
   (Other "composite_literal", []) -> Just $ S.Struct Nothing []
   (Other "composite_literal", [ty]) -> Just $ S.Struct (Just ty) []
-  (Other "composite_literal", [ty, values]) -> Just $ S.Struct (Just ty) (toList (unwrap values))
+  (Other "composite_literal", [ty, values]) -> Just $ S.Struct (Just ty) (toList (termOut values))
   (TypeAssertion, [a, b]) -> Just $ S.TypeAssertion a b
   (TypeConversion, [a, b]) -> Just $ S.TypeConversion a b
   -- TODO: Handle multiple var specs
@@ -54,8 +52,8 @@ termAssignment source category children = case (category, children) of
   (VarDecl, children) -> Just $ S.VarDecl children
   (FunctionCall, id : rest) -> Just $ S.FunctionCall id [] rest
   (AnonymousFunction, [params, _, body])
-    | [params'] <- toList (unwrap params)
-    -> Just $ S.AnonymousFunction (toList (unwrap params')) (toList (unwrap body))
+    | [params'] <- toList (termOut params)
+    -> Just $ S.AnonymousFunction (toList (termOut params')) (toList (termOut body))
   (PointerTy, _) -> Just $ S.Ty children
   (ChannelTy, _) -> Just $ S.Ty children
   (Send, [channel, expr]) -> Just $ S.Send channel expr
@@ -64,15 +62,15 @@ termAssignment source category children = case (category, children) of
   (IncrementStatement, _) -> Just $ S.Leaf (toText source)
   (DecrementStatement, _) -> Just $ S.Leaf (toText source)
   (QualifiedType, _) -> Just $ S.Leaf (toText source)
-  (Method, [receiverParams, name, body]) -> Just (S.Method [] name (Just receiverParams) [] (toList (unwrap body)))
+  (Method, [receiverParams, name, body]) -> Just (S.Method [] name (Just receiverParams) [] (toList (termOut body)))
   (Method, [receiverParams, name, params, body])
-    -> Just (S.Method [] name (Just receiverParams) [params] (toList (unwrap body)))
+    -> Just (S.Method [] name (Just receiverParams) [params] (toList (termOut body)))
   (Method, [receiverParams, name, params, ty, body])
-    -> Just (S.Method [] name (Just receiverParams) [params, ty] (toList (unwrap body)))
+    -> Just (S.Method [] name (Just receiverParams) [params, ty] (toList (termOut body)))
   _ -> Nothing
   where unpackElement element
-          | Element <- Info.category (extract element)
-          , S.Indexed [ child ] <- unwrap element = child
+          | Element <- Info.category (termAnnotation element)
+          , S.Indexed [ child ] <- termOut element = child
           | otherwise                             = element
 
 categoryForGoName :: Text -> Category

src/Parser/TreeSitter.hs

@@ -93,7 +93,7 @@ documentToTerm language document Blob{..} = do
         copyAll = TS.ts_node_copy_child_nodes document
 
 isNonEmpty :: HasField fields Category => Term S.Syntax (Record fields) -> Bool
-isNonEmpty = (/= Empty) . category . extract
+isNonEmpty = (/= Empty) . category . termAnnotation
 
 nodeRange :: TS.Node -> Range
 nodeRange TS.Node{..} = Range (fromIntegral nodeStartByte) (fromIntegral nodeEndByte)
@@ -124,7 +124,7 @@ defaultTermAssignment source annotation children allChildren
 
     -- Control flow statements
     (If, condition : body) -> toTerm $ S.If condition body
-    (Switch, _) -> let (subject, body) = break ((== Other "switch_body") . Info.category . extract) children in toTerm $ S.Switch subject (body >>= toList . unwrap)
+    (Switch, _) -> let (subject, body) = break ((== Other "switch_body") . Info.category . termAnnotation) children in toTerm $ S.Switch subject (body >>= toList . termOut)
     (Case, expr : body) -> toTerm $ S.Case expr body
     (While, expr : rest) -> toTerm $ S.While expr rest
 
@@ -141,7 +141,7 @@ defaultTermAssignment source annotation children allChildren
 
     (Other "unary_expression", _) -> do
       cs <- allChildren
-      let c = case category . extract <$> cs of
+      let c = case category . termAnnotation <$> cs of
                 [Other s, _]
                   | s `elem` ["-", "+", "++", "--"] -> MathOperator
                   | s == "~" -> BitwiseOperator
@@ -153,7 +153,7 @@ defaultTermAssignment source annotation children allChildren
 
     (Other "binary_expression", _) -> do
       cs <- allChildren
-      let c = case category . extract <$> cs of
+      let c = case category . termAnnotation <$> cs of
                 [_, Other s, _]
                   | s `elem` ["<=", "<", ">=", ">", "==", "===", "!=", "!=="] -> RelationalOperator
                   | s `elem` ["*", "+", "-", "/", "%"] -> MathOperator

src/RWS.hs

@@ -89,7 +89,7 @@ rws canCompare equivalent as bs
         --
         -- cf §4.2 of RWS-Diff
         mostSimilarMatching isEligible tree term = listToMaybe (sortOn (editDistanceUpTo optionsNodeComparisons term . snd) candidates)
-          where candidates = filter (uncurry isEligible) (snd <$> KdMap.kNearest tree optionsMaxSimilarTerms (rhead (extract term)))
+          where candidates = filter (uncurry isEligible) (snd <$> KdMap.kNearest tree optionsMaxSimilarTerms (rhead (termAnnotation term)))
 
 data Options = Options
   { optionsLookaheadPlaces :: {-# UNPACK #-} !Int -- ^ How many places ahead should we look for similar terms?
@@ -110,7 +110,7 @@ defaultQ = 3
 
 
 toKdMap :: Functor syntax => [(Int, Term syntax (Record (FeatureVector ': fields)))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (Record (FeatureVector ': fields)))
-toKdMap = KdMap.build unFV . fmap (rhead . extract . snd &&& id)
+toKdMap = KdMap.build unFV . fmap (rhead . termAnnotation . snd &&& id)
 
 -- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree.
 data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }
@@ -128,7 +128,7 @@ defaultFeatureVectorDecorator getLabel = featureVectorDecorator . pqGramDecorato
 featureVectorDecorator :: (Foldable f, Functor f, Hashable label) => Term f (Record (Gram label ': fields)) -> Term f (Record (FeatureVector ': fields))
 featureVectorDecorator = cata (\ (In (gram :. rest) functor) ->
   termIn (foldl' addSubtermVector (unitVector (hash gram)) functor :. rest) functor)
-  where addSubtermVector v term = addVectors v (rhead (extract term))
+  where addSubtermVector v term = addVectors v (rhead (termAnnotation term))
 
 -- | Annotates a term with the corresponding p,q-gram at each node.
 pqGramDecorator
@@ -154,7 +154,7 @@ pqGramDecorator getLabel p q = cata algebra
       put (drop 1 labels)
       pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) functor
     siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label]
-    siblingLabels = foldMap (base . rhead . extract)
+    siblingLabels = foldMap (base . rhead . termAnnotation)
     padToSize n list = take n (list <> repeat empty)
 
 -- | Test the comparability of two root 'Term's in O(1).
@@ -176,7 +176,7 @@ editDistanceUpTo m a b = diffCost m (approximateDiff a b)
           _ | m <= 0 -> 0
           Merge body -> sum (fmap ($ pred m) body)
           body -> succ (sum (fmap ($ pred m) body))
-        approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (Just . these deleting inserting approximateDiff) (unwrap a) (unwrap b))
+        approximateDiff a b = maybe (replacing a b) (merge (termAnnotation a, termAnnotation b)) (galignWith (Just . these deleting inserting approximateDiff) (termOut a) (termOut b))
 
 
 -- Instances

src/Renderer/TOC.hs

@@ -229,13 +229,13 @@ syntaxDeclarationAlgebra blob@Blob{..} decl@(In a r) = case r of
   S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier) (getSyntaxDeclarationSource blob decl) blobLanguage
   S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier) (getSyntaxDeclarationSource blob decl) blobLanguage Nothing
   S.Method _ (identifier, _) (Just (receiver, _)) _ _
-    | S.Indexed [receiverParams] <- unwrap receiver
-    , S.ParameterDecl (Just ty) _ <- unwrap receiverParams -> Just $ MethodDeclaration (getSource identifier) (getSyntaxDeclarationSource blob decl) blobLanguage (Just (getSource ty))
+    | S.Indexed [receiverParams] <- termOut receiver
+    , S.ParameterDecl (Just ty) _ <- termOut receiverParams -> Just $ MethodDeclaration (getSource identifier) (getSyntaxDeclarationSource blob decl) blobLanguage (Just (getSource ty))
     | otherwise -> Just $ MethodDeclaration (getSource identifier) (getSyntaxDeclarationSource blob decl) blobLanguage (Just (getSource receiver))
   S.ParseError{} -> Just $ ErrorDeclaration (toText (Source.slice (byteRange a) blobSource)) mempty blobLanguage
   _ -> Nothing
   where
-    getSource = toText . flip Source.slice blobSource . byteRange . extract
+    getSource = toText . flip Source.slice blobSource . byteRange . termAnnotation
 
 getMethodSource :: HasField fields Range => Blob -> TermF Declaration.Method (Record fields) (Term syntax (Record fields), a) -> T.Text
 getMethodSource Blob{..} (In a r)