Give our own definition of CofreeF.

2024-12-19 12:51:52 +03:00 · 2017-09-08 16:40:23 +01:00 · 2017-09-08 16:40:23 +01:00 · aa9d4c4f19
commit aa9d4c4f19
parent 1a6af2179b
19 changed files with 65 additions and 84 deletions
--- a/src/Algorithm.hs
+++ b/src/Algorithm.hs
@ -2,7 +2,6 @@
 module Algorithm where

 import Control.Applicative (liftA2)
-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Control.Monad (guard, join)
 import Control.Monad.Free (wrap)
 import Control.Monad.Free.Freer hiding (wrap)
@ -89,9 +88,7 @@ instance Show term => Show1 (AlgorithmF term diff) where
 -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable
 -- (represented by a Nothing diff returned from algorithmFor) replace one term with another.
 algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a)
-algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 CofreeF.:<)) <$> algorithmFor f1 f2)
-  where ann1 CofreeF.:< f1 = runCofree t1
-        ann2 CofreeF.:< f2 = runCofree t2
+algorithmForTerms t1@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (wrap . (both ann1 ann2 :<<)) <$> algorithmFor f1 f2)


 -- | A type class for determining what algorithm to use for diffing two terms.
--- a/src/Alignment.hs
+++ b/src/Alignment.hs
@ -10,7 +10,6 @@ module Alignment

 import Data.Bifunctor (bimap, first, second)
 import Control.Arrow ((***))
-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Control.Monad (join)
 import Control.Monad.Free
 import Data.Align
@ -66,12 +65,12 @@ alignPatch sources patch = case patch of

 -- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff.
 alignSyntax :: (Applicative f, HasField fields Range, Foldable g) => (forall a. f a -> Join These a) -> (TermF [] (Record fields) term -> term) -> (term -> Range) -> f Source -> TermF g (f (Record fields)) [Join These term] -> [Join These term]
-alignSyntax toJoinThese toNode getRange sources (infos CofreeF.:< syntax) =
+alignSyntax toJoinThese toNode getRange sources (infos :<< syntax) =
  catMaybes $ wrapInBranch <$> alignBranch getRange (join (toList syntax)) bothRanges
  where bothRanges = modifyJoin (fromThese [] []) lineRanges
        lineRanges = toJoinThese $ sourceLineRangesWithin . byteRange <$> infos <*> sources
        wrapInBranch = applyThese $ toJoinThese (makeNode <$> infos)
-        makeNode info (range, children) = toNode (setByteRange info range CofreeF.:< children)
+        makeNode info (range, children) = toNode (setByteRange info range :<< children)

 -- | Given a function to get the range, a list of already-aligned children, and the lists of ranges spanned by a branch, return the aligned lines.
 alignBranch :: (term -> Range) -> [Join These term] -> Both [Range] -> [Join These (Range, [term])]
--- a/src/Data/Syntax.hs
+++ b/src/Data/Syntax.hs
@ -3,7 +3,6 @@ module Data.Syntax where

 import Algorithm
 import Control.Applicative
-import Control.Comonad.Trans.Cofree (CofreeF(..))
 import Control.Monad.Error.Class hiding (Error)
 import Data.Align.Generic
 import Data.ByteString (ByteString)
@ -23,7 +22,7 @@ import Data.Text.Encoding (decodeUtf8With)
 import Data.Union
 import GHC.Generics
 import GHC.Stack
-import Term hiding ((:<))
+import Term

 -- Combinators

@ -33,7 +32,7 @@ makeTerm a = makeTerm' a . inj

 -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
 makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
-makeTerm' a f = cofree (sconcat (a :| (headF . runCofree <$> toList f)) :< f)
+makeTerm' a f = (sconcat (a :| (headF . runCofree <$> toList f)) :< f)

 -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
 makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
--- a/src/Data/Syntax/Algebra.hs
+++ b/src/Data/Syntax/Algebra.hs
@ -8,7 +8,6 @@ module Data.Syntax.Algebra
 , cyclomaticComplexityAlgebra
 ) where

-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Data.Bifunctor (second)
 import Data.ByteString (ByteString)
 import Data.Functor.Foldable
@ -34,7 +33,7 @@ decoratorWithAlgebra :: Functor f
                     => RAlgebra (Base (Term f (Record fs))) (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@(a CofreeF.:< f) -> (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f
+decoratorWithAlgebra alg = para $ \ c@(a :<< f) -> (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f


 newtype Identifier = Identifier ByteString
@ -44,7 +43,7 @@ newtype Identifier = Identifier ByteString
 --
 --   Identifier syntax is labelled, as well as declaration syntax identified by these, but other uses of these identifiers are not, e.g. the declaration of a class or method or binding of a variable will be labelled, but a function call will not.
 identifierAlgebra :: (Syntax.Identifier :< fs, Declaration.Method :< fs, Declaration.Class :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) (Maybe Identifier)
-identifierAlgebra (_ CofreeF.:< union) = case union of
+identifierAlgebra (_ :<< union) = case union of
  _ | Just (Syntax.Identifier s) <- prj union -> Just (Identifier s)
  _ | Just Declaration.Class{..} <- prj union -> classIdentifier
  _ | Just Declaration.Method{..} <- prj union -> methodName
@ -60,7 +59,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int
 --   TODO: Anonymous functions should not increase parent scope’s complexity.
 --   TODO: Inner functions should not increase parent scope’s complexity.
 cyclomaticComplexityAlgebra :: (Declaration.Method :< fs, Statement.Return :< fs, Statement.Yield :< fs, Apply1 Foldable fs, Apply1 Functor fs) => FAlgebra (Base (Term (Union fs) a)) CyclomaticComplexity
-cyclomaticComplexityAlgebra (_ CofreeF.:< union) = case union of
+cyclomaticComplexityAlgebra (_ :<< union) = case union of
  _ | Just Declaration.Method{} <- prj union -> succ (sum union)
  _ | Just Statement.Return{} <- prj union -> succ (sum union)
  _ | Just Statement.Yield{} <- prj union -> succ (sum union)
--- a/src/Data/Syntax/Assignment.hs
+++ b/src/Data/Syntax/Assignment.hs
@ -95,7 +95,6 @@ module Data.Syntax.Assignment

 import Control.Arrow ((&&&))
 import Control.Applicative
-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Control.Monad (guard)
 import Control.Monad.Error.Class hiding (Error)
 import Control.Monad.Free.Freer
@ -116,7 +115,7 @@ import qualified Data.Source as Source (Source, slice, sourceBytes)
 import GHC.Stack
 import qualified Info
 import Prelude hiding (until)
-import Term as Cofree
+import Term
 import Text.Parser.Combinators as Parsers
 import TreeSitter.Language

@ -128,7 +127,7 @@ type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar))
 data AssignmentF ast grammar a where
  End :: AssignmentF ast grammar ()
  Location :: AssignmentF ast grammar (Record Location)
-  CurrentNode :: AssignmentF ast grammar (CofreeF.CofreeF ast (Node grammar) ())
+  CurrentNode :: AssignmentF ast grammar (CofreeF ast (Node grammar) ())
  Source :: AssignmentF ast grammar ByteString
  Children :: Assignment ast grammar a -> AssignmentF ast grammar a
  Advance :: AssignmentF ast grammar ()
@ -158,7 +157,7 @@ location :: HasCallStack => Assignment ast grammar (Record Location)
 location = tracing Location `Then` return

 -- | Zero-width production of the current node.
-currentNode :: HasCallStack => Assignment ast grammar (CofreeF.CofreeF ast (Node grammar) ())
+currentNode :: HasCallStack => Assignment ast grammar (CofreeF ast (Node grammar) ())
 currentNode = tracing CurrentNode `Then` return

 -- | Zero-width match of a node with the given symbol, producing the current node’s location.
@ -259,7 +258,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
        run t yield initialState = expectedSymbols `seq` state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
          where atNode (node :< f) = case runTracing t of
                  Location -> yield (nodeLocation node) state
-                  CurrentNode -> yield (node CofreeF.:< (() <$ f)) state
+                  CurrentNode -> yield (node :<< (() <$ f)) state
                  Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
                  Children child -> do
                    (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t)
@ -298,7 +297,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n
 -- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged.
 advanceState :: State ast grammar -> State ast grammar
 advanceState state@State{..}
-  | (Node{..} Cofree.:< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest
+  | (Node{..} :< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest
  | otherwise = state

 -- | State kept while running 'Assignment's.
--- a/src/Decorators.hs
+++ b/src/Decorators.hs
@ -5,7 +5,6 @@ module Decorators
 , constructorLabel
 ) where

-import Control.Comonad.Trans.Cofree (CofreeF(..))
 import Data.Aeson
 import Data.ByteString.Char8 (ByteString, pack, unpack)
 import Data.Functor.Classes (Show1 (liftShowsPrec))
@ -14,18 +13,18 @@ import Data.Text.Encoding (decodeUtf8)
 import Data.Union
 import GHC.Generics
 import Renderer.JSON
-import Term hiding ((:<))
+import Term

 -- | Compute a 'ByteString' label for a 'Show1'able 'Term'.
 --
 --   This uses 'liftShowsPrec' to produce the 'ByteString', with the effect that
 --   constant fields will be included and parametric fields will not be.
 constructorNameAndConstantFields :: Show1 f => TermF f a b -> ByteString
-constructorNameAndConstantFields (_ :< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")
+constructorNameAndConstantFields (_ :<< f) = pack (liftShowsPrec (const (const id)) (const id) 0 f "")

 -- | Compute a 'ConstructorLabel' label for a 'Union' of syntax 'Term's.
 constructorLabel :: Apply1 ConstructorName fs => TermF (Union fs) a b -> ConstructorLabel
-constructorLabel (_ :< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u)
+constructorLabel (_ :<< u) = ConstructorLabel $ pack (apply1 (Proxy :: Proxy ConstructorName) constructorName u)


 newtype ConstructorLabel = ConstructorLabel ByteString
--- a/src/Diff.hs
+++ b/src/Diff.hs
@ -2,7 +2,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Diff where

-import qualified Control.Comonad.Trans.Cofree as CofreeF
 import Control.DeepSeq
 import qualified Control.Monad.Free as Free
 import qualified Control.Monad.Trans.Free as FreeF
@ -31,7 +30,7 @@ diffCost = diffSum $ patchSum termSize
 -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch.
 mergeMaybe :: Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation)
 mergeMaybe transform extractAnnotation = Free.iter algebra . fmap transform
-  where algebra (annotations CofreeF.:< syntax) = cofree . (extractAnnotation annotations CofreeF.:<) <$> sequenceAlt syntax
+  where algebra (annotations :<< syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax

 -- | Recover the before state of a diff.
 beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation)
--- a/src/Interpreter.hs
+++ b/src/Interpreter.hs
@ -7,7 +7,6 @@ module Interpreter
 ) where

 import Algorithm
-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Control.Monad.Free (cutoff, wrap)
 import Control.Monad.Free.Freer hiding (cutoff, wrap)
 import Data.Align.Generic
@ -51,7 +50,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b)
        decompose step = case step of
          Diff t1 t2 -> refine t1 t2
          Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of
-            Just result -> wrap . (both (extract t1) (extract t2) CofreeF.:<) <$> sequenceA result
+            Just result -> wrap . (both (extract t1) (extract t2) :<<) <$> sequenceA result
            _ -> byReplacing t1 t2
          RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs)
          Delete a -> pure (deleting a)
@ -60,7 +59,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b)

 -- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram.
 getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text)
-getLabel (h CofreeF.:< t) = (Info.category h, case t of
+getLabel (h :<< t) = (Info.category h, case t of
  Leaf s -> Just s
  _ -> Nothing)

@ -106,16 +105,16 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
               <*> byRWS bodyA bodyB
  _ -> linearly t1 t2
  where
-    annotate = wrap . (both (extract t1) (extract t2) CofreeF.:<)
+    annotate = wrap . (both (extract t1) (extract t2) :<<)


 -- | Test whether two terms are comparable by their Category.
 comparableByCategory :: HasField fields Category => ComparabilityRelation f fields
-comparableByCategory (a CofreeF.:< _) (b CofreeF.:< _) = category a == category b
+comparableByCategory (a :<< _) (b :<< _) = category a == category b

 -- | Test whether two terms are comparable by their constructor.
 comparableByConstructor :: GAlign f => ComparabilityRelation f fields
-comparableByConstructor (_ CofreeF.:< a) (_ CofreeF.:< b) = isJust (galign a b)
+comparableByConstructor (_ :<< a) (_ :<< b) = isJust (galign a b)


 -- | How many nodes to consider for our constant-time approximation to tree edit distance.
--- a/src/Language/Markdown.hs
+++ b/src/Language/Markdown.hs
@ -5,7 +5,6 @@ module Language.Markdown
 , toGrammar
 ) where

-import Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import CMarkGFM
 import Data.Ix
 import Data.Source
@ -55,7 +54,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT
        toTerm within withinSpan (Node position t children) =
          let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position
              span = maybe withinSpan toSpan position
-          in (A.Node (toGrammar t) range span) Cofree.:< (t CofreeF.:< (toTerm range span <$> children))
+          in (A.Node (toGrammar t) range span) :< (t :<< (toTerm range span <$> children))

        toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn)))

--- a/src/Language/Markdown/Syntax.hs
+++ b/src/Language/Markdown/Syntax.hs
@ -20,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Union
 import GHC.Stack
 import Language.Markdown as Grammar (Grammar(..))
-import Term (Cofree(..), CofreeF, unwrap, headF, tailF)
+import Term (Cofree(..), CofreeF(..), unwrap, headF, tailF)
 import qualified Term

 type Syntax =
--- a/src/RWS.hs
+++ b/src/RWS.hs
@ -14,8 +14,6 @@ module RWS (

 import Control.Applicative (empty)
 import Control.Arrow ((&&&))
-import Control.Comonad
-import Control.Comonad.Trans.Cofree hiding (cofree, runCofree)
 import Control.Monad.Free
 import Control.Monad.State.Strict
 import Data.Foldable
@ -30,7 +28,7 @@ import Data.Semigroup hiding (First(..))
 import Data.These
 import Data.Traversable
 import Patch
-import Term hiding ((:<))
+import Term
 import Data.Array.Unboxed
 import Data.Functor.Classes
 import SES
@ -228,8 +226,7 @@ featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record
 featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term)

 eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields)
-eraseFeatureVector term = let record :< functor = runCofree term in
-  cofree (setFeatureVector record nullFeatureVector :< functor)
+eraseFeatureVector (record :< functor) = setFeatureVector record nullFeatureVector :< functor

 nullFeatureVector :: FeatureVector
 nullFeatureVector = listArray (0, 0) [0]
@ -263,7 +260,7 @@ featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields labe
 featureVectorDecorator getLabel p q d
 = cata collect
 . pqGramDecorator getLabel p q
- where collect ((gram :. rest) :< functor) = cofree ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor)
+ where collect ((gram :. rest) :<< functor) = ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor)
       addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector
       addSubtermVector v term = addVectors v (rhead (extract term))

@ -281,7 +278,7 @@ pqGramDecorator
 pqGramDecorator getLabel p q = cata algebra
  where
    algebra term = let label = getLabel term in
-      cofree ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label)
+      ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label)
    gram label = Gram (padToSize p []) (padToSize q (pure (Just label)))
    assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label))

@ -289,11 +286,10 @@ pqGramDecorator getLabel p q = cata algebra
                 => label
                 -> Term f (Record (Gram label ': fields))
                 -> State [Maybe label] (Term f (Record (Gram label ': fields)))
-    assignLabels label a = case runCofree a of
-      (gram :. rest) :< functor -> do
-        labels <- get
-        put (drop 1 labels)
-        pure $! cofree ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) :< functor)
+    assignLabels label ((gram :. rest) :< functor) = do
+      labels <- get
+      put (drop 1 labels)
+      pure $! ((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)
    padToSize n list = take n (list <> repeat empty)
--- a/src/Renderer.hs
+++ b/src/Renderer.hs
@ -18,7 +18,6 @@ module Renderer
 , File(..)
 ) where

-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Control.DeepSeq
 import Data.Aeson (Value, (.=))
 import Data.ByteString (ByteString)
@ -76,7 +75,7 @@ data SomeRenderer f where
 deriving instance Show (SomeRenderer f)

 identifierAlgebra :: RAlgebra (CofreeF Syntax a) (Cofree Syntax a) (Maybe Identifier)
-identifierAlgebra (_ CofreeF.:< syntax) = case syntax of
+identifierAlgebra (_ :<< syntax) = case syntax of
  S.Assignment f _ -> identifier f
  S.Class f _ _ -> identifier f
  S.Export f _ -> f >>= identifier
--- a/src/Renderer/JSON.hs
+++ b/src/Renderer/JSON.hs
@ -6,7 +6,6 @@ module Renderer.JSON
 , ToJSONFields(..)
 ) where

-import qualified Control.Comonad.Trans.Cofree as CofreeF
 import Control.Monad.Free
 import qualified Control.Monad.Trans.Free as FreeF
 import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
@ -89,8 +88,8 @@ instance ToJSONFields a => ToJSONFields (Maybe a) where
 instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSONFields (Cofree f a) where
  toJSONFields (a :< f) = toJSONFields a <> toJSONFields f

-instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (CofreeF.CofreeF f a b) where
-  toJSONFields (a CofreeF.:< f) = toJSONFields a <> toJSONFields f
+instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (CofreeF f a b) where
+  toJSONFields (a :<< f) = toJSONFields a <> toJSONFields f

 instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSONFields (Free f a) where
  toJSONFields (Free f) = toJSONFields f
--- a/src/Renderer/SExpression.hs
+++ b/src/Renderer/SExpression.hs
@ -4,7 +4,6 @@ module Renderer.SExpression
 , renderSExpressionTerm
 ) where

-import Control.Comonad.Trans.Cofree hiding (runCofree)
 import Control.Monad.Trans.Free hiding (runFree)
 import Data.Bifunctor.Join
 import Data.ByteString.Char8 hiding (foldr, spanEnd)
@ -13,7 +12,7 @@ import Data.Semigroup
 import Diff
 import Patch
 import Prelude hiding (replicate)
-import Term hiding ((:<))
+import Term

 -- | Returns a ByteString SExpression formatted diff.
 renderSExpressionDiff :: (ConstrainAll Show fields, Foldable f) => Diff f (Record fields) -> ByteString
@ -29,7 +28,7 @@ printDiff diff level = case runFree diff of
    Insert term -> pad (level - 1) <> "{+" <> printTerm term level <> "+}"
    Delete term -> pad (level - 1) <> "{-" <> printTerm term level <> "-}"
    Replace a b -> pad (level - 1) <> "{ " <> printTerm a level <> pad (level - 1) <> "->" <> printTerm b level <> " }"
-  Free (Join (_, annotation) :< syntax) -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")"
+  Free (Join (_, annotation) :<< syntax) -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")"
  where
    pad' :: Int -> ByteString
    pad' n = if n < 1 then "" else pad n
@ -45,8 +44,8 @@ printTerm term level = go term level 0
    pad p n | n < 1 = ""
            | otherwise = "\n" <> replicate (2 * (p + n)) ' '
    go :: (ConstrainAll Show fields, Foldable f) => Term f (Record fields) -> Int -> Int -> ByteString
-    go term parentLevel level = case runCofree term of
-      (annotation :< syntax) -> pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")"
+    go (annotation :< syntax) parentLevel level =
+      pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")"

 showAnnotation :: ConstrainAll Show fields => Record fields -> ByteString
 showAnnotation Nil = ""
--- a/src/Renderer/TOC.hs
+++ b/src/Renderer/TOC.hs
@ -17,7 +17,6 @@ module Renderer.TOC
 , entrySummary
 ) where

-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Control.DeepSeq
 import Control.Monad.Free (iter)
 import Data.Aeson
@ -101,12 +100,12 @@ getDeclaration = getField

 -- | Produce the annotations of nodes representing declarations.
 declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields)
-declaration (annotation CofreeF.:< _) = annotation <$ (getField annotation :: Maybe Declaration)
+declaration (annotation :<< _) = annotation <$ (getField annotation :: Maybe Declaration)


 -- | Compute 'Declaration's for methods and functions in 'Syntax'.
 syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration)
-syntaxDeclarationAlgebra Blob{..} (a CofreeF.:< r) = case r of
+syntaxDeclarationAlgebra Blob{..} (a :<< r) = case r of
  S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier)
  S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier)
  S.Method _ (identifier, _) (Just (receiver, _)) _ _
@ -121,7 +120,7 @@ syntaxDeclarationAlgebra Blob{..} (a CofreeF.:< r) = case r of
 declarationAlgebra :: (Declaration.Function :< fs, Declaration.Method :< fs, Syntax.Error :< fs, Apply1 Functor fs, HasField fields Range, HasField fields Span)
                   => Blob
                   -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
-declarationAlgebra blob@Blob{..} (a CofreeF.:< r)
+declarationAlgebra blob@Blob{..} (a :<< r)
  | Just (Declaration.Function (identifier, _) _ _) <- prj r = Just $ FunctionDeclaration (getSource (extract identifier))
  | Just (Declaration.Method _ (identifier, _) _ _) <- prj r = Just $ MethodDeclaration (getSource (extract identifier))
  | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage
@ -132,7 +131,7 @@ declarationAlgebra blob@Blob{..} (a CofreeF.:< r)
 markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error :< fs, HasField fields Range, HasField fields Span, Apply1 Functor fs, Apply1 Foldable fs)
                     => Blob
                     -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration)
-markupSectionAlgebra blob@Blob{..} (a CofreeF.:< r)
+markupSectionAlgebra blob@Blob{..} (a :<< r)
  | Just (Markup.Section level (heading, _) _) <- prj r = Just $ SectionDeclaration (maybe (getSource (extract heading)) (firstLine . toText . flip Source.slice blobSource . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) level
  | Just err@Syntax.Error{} <- prj r = Just $ ErrorDeclaration (T.pack (formatError False False blob (Syntax.unError (sourceSpan a) err))) blobLanguage
  | otherwise = Nothing
--- a/src/Semantic/Task.hs
+++ b/src/Semantic/Task.hs
@ -24,7 +24,6 @@ module Semantic.Task
 , runTaskWithOptions
 ) where

-import qualified Control.Comonad.Trans.Cofree as CofreeF (CofreeF(..))
 import Control.Concurrent.STM.TMQueue
 import Control.Exception
 import Control.Monad.Error.Class
@ -221,7 +220,7 @@ runParser Options{..} blob@Blob{..} = go
          LineByLineParser -> logTiming "line-by-line parse" $ pure (lineByLineParser blobSource)
        blobFields = [ ("path", blobPath), ("language", maybe "" show blobLanguage) ]
        errors :: (Syntax.Error :< fs, Apply1 Foldable fs, Apply1 Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String]
-        errors = cata $ \ (a CofreeF.:< syntax) -> case syntax of
+        errors = cata $ \ (a :<< syntax) -> case syntax of
          _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (sourceSpan a) err]
          _ -> fold syntax
        logTiming :: String -> Task a -> Task a
--- a/src/SplitDiff.hs
+++ b/src/SplitDiff.hs
@ -1,11 +1,9 @@
 module SplitDiff where

-import Control.Comonad
-import Control.Comonad.Trans.Cofree
 import Control.Monad.Free
 import Data.Record
 import Info
-import Term (Term, TermF)
+import Term

 -- | A patch to only one side of a diff.
 data SplitPatch a
--- a/src/Term.hs
+++ b/src/Term.hs
@ -13,17 +13,15 @@ module Term
 , extract
 , unwrap
 , hoistCofree
-, CofreeF.headF
-, CofreeF.tailF
-, CofreeF.CofreeF()
+, CofreeF(..)
 ) where

 import Control.Comonad
 import Control.Comonad.Cofree.Class
-import qualified Control.Comonad.Trans.Cofree as CofreeF
 import Control.DeepSeq
 import Control.Monad.Free
 import Data.Align.Generic
+import Data.Bifunctor
 import Data.Functor.Both
 import Data.Functor.Classes.Pretty.Generic
 import Data.Functor.Foldable
@ -35,11 +33,13 @@ import Data.Union
 import Syntax

 -- | A Term with an abstract syntax tree and an annotation.
-type Term f = Cofree f
-type TermF = CofreeF.CofreeF
+type Term = Cofree
+type TermF = CofreeF

 infixr 5 :<
 data Cofree f a = a :< f (Cofree f a)
+data CofreeF f a b = (:<<) { headF :: a, tailF :: f b }
+  deriving (Eq, Foldable, Functor, Show, Traversable)

 -- | A Term with a Syntax leaf and a record of fields.
 type SyntaxTerm fields = Term Syntax (Record fields)
@ -48,19 +48,19 @@ type SyntaxTermF fields = TermF Syntax (Record fields)
 instance (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where
  rnf = rnf . runCofree

-instance (NFData a, NFData (f b)) => NFData (CofreeF.CofreeF f a b) where
-  rnf (a CofreeF.:< s) = rnf a `seq` rnf s `seq` ()
+instance (NFData a, NFData (f b)) => NFData (CofreeF f a b) where
+  rnf (a :<< s) = rnf a `seq` rnf s `seq` ()

 -- | Zip two terms by combining their annotations into a pair of annotations.
 -- | If the structure of the two terms don't match, then Nothing will be returned.
 zipTerms :: (Traversable f, GAlign f) => Term f annotation -> Term f annotation -> Maybe (Term f (Both annotation))
 zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2))
-  where go (a CofreeF.:< s) = cofree . (a CofreeF.:<) <$> sequenceA s
+  where go (a :<< s) = (a :<) <$> sequenceA s

 -- | Return the node count of a term.
 termSize :: (Foldable f, Functor f) => Term f annotation -> Int
 termSize = cata size where
-  size (_ CofreeF.:< syntax) = 1 + sum syntax
+  size (_ :<< syntax) = 1 + sum syntax

 -- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms.
 alignCofreeWith :: Functor f
@ -71,15 +71,15 @@ alignCofreeWith :: Functor f
  -> Free (TermF f combined) contrasted
 alignCofreeWith compare contrast combine = go
  where go terms = fromMaybe (pure (contrast terms)) $ case terms of
-          These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 CofreeF.:<) . fmap go <$> compare f1 f2
+          These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 :<<) . fmap go <$> compare f1 f2
          _ -> Nothing


-cofree :: CofreeF.CofreeF f a (Cofree f a) -> Cofree f a
-cofree (a CofreeF.:< f) = a :< f
+cofree :: CofreeF f a (Cofree f a) -> Cofree f a
+cofree (a :<< f) = a :< f

-runCofree :: Cofree f a -> CofreeF.CofreeF f a (Cofree f a)
-runCofree (a :< f) = a CofreeF.:< f
+runCofree :: Cofree f a -> CofreeF f a (Cofree f a)
+runCofree (a :< f) = a :<< f

 hoistCofree :: Functor f => (forall a. f a -> g a) -> Cofree f a -> Cofree g a
 hoistCofree f = go where go (a :< r) = a :< f (fmap go r)
@ -93,7 +93,7 @@ instance (Pretty1 f, Pretty a) => Pretty (Cofree f a) where
 instance Apply1 Pretty1 fs => Pretty1 (Union fs) where
  liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl)

-type instance Base (Cofree f a) = CofreeF.CofreeF f a
+type instance Base (Cofree f a) = CofreeF f a

 instance Functor f => Recursive (Cofree f a) where project = runCofree
 instance Functor f => Corecursive (Cofree f a) where embed = cofree
@ -115,3 +115,6 @@ instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where

 instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where
  showsPrec d (a :< f) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 f
+
+instance Functor f => Bifunctor (CofreeF f) where
+  bimap f g (a :<< r) = f a :<< fmap g r
--- a/src/TreeSitter.hs
+++ b/src/TreeSitter.hs
@ -65,7 +65,7 @@ toAST node@TS.Node{..} = do
  children <- allocaArray count $ \ childNodesPtr -> do
    _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nullPtr nodePtr childNodesPtr (fromIntegral count))
    peekArray count childNodesPtr
-  pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) CofreeF.:< children
+  pure $! A.Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node) :<< children

 anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t
 anaM g = a where a = pure . embed <=< traverse a <=< g