Redefine Term as a wrapper for TermF.

src/Algorithm.hs

@@ -87,7 +87,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@(ann1 :< f1) t2@(ann2 :< f2) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . Copy (both ann1 ann2)) <$> algorithmFor f1 f2)
+algorithmForTerms t1@(Term (ann1 :< f1)) t2@(Term (ann2 :< f2)) = fromMaybe (byReplacing t1 t2) (fmap (Diff.Diff . Copy (both ann1 ann2)) <$> algorithmFor f1 f2)
 
 
 -- | A type class for determining what algorithm to use for diffing two terms.

src/Alignment.hs

@@ -48,7 +48,7 @@ hasChanges = or . (True <$)
 -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side.
 alignDiff :: Traversable f => HasField fields Range => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))]
 alignDiff sources = cata $ \ diff -> case diff of
-  Copy ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :<< r)
+  Copy ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :< r)
   Patch patch -> alignPatch sources patch
 
 -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff.
@@ -61,18 +61,18 @@ alignPatch sources patch = case patch of
     (alignSyntax' that (snd sources) term2)
   where getRange = byteRange . extract
         alignSyntax' :: (forall a. Identity a -> Join These a) -> Source -> Term f (Record fields) -> [Join These (Term [] (Record fields))]
-        alignSyntax' side source = hylo (alignSyntax side term getRange (Identity source)) unTerm . fmap Identity
+        alignSyntax' side source = hylo (alignSyntax side Term getRange (Identity source)) unTerm . fmap Identity
         this = Join . This . runIdentity
         that = Join . That . runIdentity
 
 -- | 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 :<< 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 :<< 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])]

src/Data/Syntax.hs

@@ -32,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 = (sconcat (a :| (headF . unTerm <$> toList f)) :< f)
+makeTerm' a f = Term (sconcat (a :| (headF . unTerm <$> 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

src/Data/Syntax/Algebra.hs

@@ -33,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 :<< f) -> (alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f
+decoratorWithAlgebra alg = para $ \ c@(a :< f) -> Term ((alg (fmap (second (rhead . extract)) c) :. a) :< fmap snd f)
 
 
 newtype Identifier = Identifier ByteString
@@ -43,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 (_ :<< 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
@@ -59,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 (_ :<< 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)

src/Data/Syntax/Assignment.hs

@@ -256,9 +256,9 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
             -> State ast grammar
             -> Either (Error (Either String grammar)) (result, State ast grammar)
         run t yield initialState = expectedSymbols `seq` state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
-          where atNode (node :< f) = case runTracing t of
+          where atNode (Term (node :< f)) = case runTracing t of
                   Location -> yield (nodeLocation node) state
-                  CurrentNode -> yield (node :<< (() <$ 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)
@@ -286,7 +286,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
 requireExhaustive :: Symbol grammar => Maybe (String, SrcLoc) -> (result, State ast grammar) -> Either (Error (Either String grammar)) (result, State ast grammar)
 requireExhaustive callSite (a, state) = let state' = skipTokens state in case stateNodes state' of
   [] -> Right (a, state')
-  (node :< _) : _ -> Left (withStateCallStack callSite state (nodeError [] node))
+  Term (node :< _) : _ -> Left (withStateCallStack callSite state (nodeError [] node))
 
 withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallStack => a) -> a
 withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action
@@ -297,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{..} :< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest
+  | Term (Node{..} :< _) : rest <- stateNodes = State (Info.end nodeByteRange) (Info.spanEnd nodeSpan) stateCallSites rest
   | otherwise = state
 
 -- | State kept while running 'Assignment's.

src/Decorators.hs

@@ -20,11 +20,11 @@ import 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

src/Diff.hs

@@ -34,8 +34,8 @@ 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 syntax => (Patch (Term syntax annotation) -> Maybe (Term syntax annotation)) -> (Both annotation -> annotation) -> Diff syntax annotation -> Maybe (Term syntax annotation)
 mergeMaybe transform extractAnnotation = cata algebra
-  where algebra (Copy annotations syntax) = (extractAnnotation annotations :<) <$> sequenceAlt syntax
-        algebra (Patch term) = transform term
+  where algebra (Copy annotations syntax) = Term . (extractAnnotation annotations :<) <$> sequenceAlt syntax
+        algebra (Patch patch) = transform patch
 
 -- | Recover the before state of a diff.
 beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation)
@@ -67,7 +67,7 @@ deleting = Diff . Patch . Delete
 
 
 wrapTermF :: TermF syntax (Both ann) (Diff syntax ann) -> Diff syntax ann
-wrapTermF (a :<< r) = Diff (Copy a r)
+wrapTermF (a :< r) = Diff (Copy a r)
 
 
 instance Apply1 Pretty1 fs => Pretty1 (Diff (Union fs)) where

src/Interpreter.hs

@@ -58,7 +58,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 :<< t) = (Info.category h, case t of
+getLabel (h :< t) = (Info.category h, case t of
   Leaf s -> Just s
   _ -> Nothing)
 
@@ -109,11 +109,11 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
 
 -- | Test whether two terms are comparable by their Category.
 comparableByCategory :: HasField fields Category => ComparabilityRelation f fields
-comparableByCategory (a :<< _) (b :<< _) = 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 (_ :<< a) (_ :<< 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.

src/Language.hs

@@ -38,19 +38,19 @@ languageForType mediaType = case mediaType of
 
 toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
 toVarDeclOrAssignment child = case unwrap child of
-  S.Indexed [child', assignment] -> setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment
-  S.Indexed [child'] -> setCategory (extract child) VarDecl :< S.VarDecl [child']
-  S.VarDecl _ -> setCategory (extract child) VarDecl :< unwrap child
+  S.Indexed [child', assignment] -> Term (setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment)
+  S.Indexed [child'] -> Term (setCategory (extract child) VarDecl :< S.VarDecl [child'])
+  S.VarDecl _ -> Term (setCategory (extract child) VarDecl :< unwrap child)
   S.VarAssignment _ _ -> child
   _ -> toVarDecl child
 
 toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
-toVarDecl child = setCategory (extract child) VarDecl :< S.VarDecl [child]
+toVarDecl child = Term (setCategory (extract child) VarDecl :< S.VarDecl [child])
 
 toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)]
-toTuple child | S.Indexed [key,value] <- unwrap child = [extract child :< S.Pair key value]
-toTuple child | S.Fixed [key,value] <- unwrap child = [extract child :< S.Pair key value]
-toTuple child | S.Leaf c <- unwrap child = [extract child :< S.Comment c]
+toTuple child | S.Indexed [key,value] <- unwrap child = [Term (extract child :< S.Pair key value)]
+toTuple child | S.Fixed [key,value] <- unwrap child = [Term (extract child :< S.Pair key value)]
+toTuple child | S.Leaf c <- unwrap child = [Term (extract child :< S.Comment c)]
 toTuple child = pure child
 
 toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields))

src/Language/Markdown.hs

@@ -54,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) :< (t :<< (toTerm range span <$> children))
+          in Term ((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)))
 

src/Language/Markdown/Syntax.hs

@@ -3,7 +3,7 @@ module Language.Markdown.Syntax
 ( assignment
 , Syntax
 , Grammar
-, Term
+, Language.Markdown.Syntax.Term
 ) where
 
 import qualified CMarkGFM
@@ -20,8 +20,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Union
 import GHC.Stack
 import Language.Markdown as Grammar (Grammar(..))
-import Term (TermF(..), unwrap, headF, tailF)
-import qualified Term
+import Term (Term(..), TermF(..), unwrap, headF, tailF)
 
 type Syntax =
   '[ Markup.Document
@@ -52,7 +51,7 @@ type Syntax =
    ]
 
 type Term = Term.Term (Union Syntax) (Record Location)
-type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Term
+type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Language.Markdown.Syntax.Term
 
 
 assignment :: Assignment
@@ -68,7 +67,7 @@ paragraph :: Assignment
 paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement)
 
 list :: Assignment
-list = (Term.:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of
+list = (Term .) . (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of
   CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList
   CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . headF . tailF <$> currentNode <*> children (many item))
 

src/Language/Ruby.hs

@@ -57,10 +57,10 @@ termAssignment _ category children
       -> Just $ S.FunctionCall fn [] (toList . unwrap =<< args)
     (Object, _ ) -> Just . S.Object Nothing $ foldMap toTuple children
     (Modifier If, [ lhs, condition ]) -> Just $ S.If condition [lhs]
-    (Modifier Unless, [lhs, rhs]) -> Just $ S.If (setCategory (extract rhs) Negate :< S.Negate rhs) [lhs]
-    (Unless, expr : rest) -> Just $ S.If ((setCategory (extract expr) Negate) :< S.Negate expr) rest
-    (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (setCategory (extract rhs) Negate :< S.Negate rhs) [lhs]
-    (Until, expr : rest) -> Just $ S.While (setCategory (extract expr) Negate :< S.Negate expr) rest
+    (Modifier Unless, [lhs, rhs]) -> Just $ S.If (Term (setCategory (extract rhs) Negate :< S.Negate rhs)) [lhs]
+    (Unless, expr : rest) -> Just $ S.If (Term (setCategory (extract expr) Negate :< S.Negate expr)) rest
+    (Modifier Until, [ lhs, rhs ]) -> Just $ S.While (Term (setCategory (extract rhs) Negate :< S.Negate rhs)) [lhs]
+    (Until, expr : rest) -> Just $ S.While (Term (setCategory (extract expr) Negate :< S.Negate expr)) rest
     (Elsif, condition : body ) -> Just $ S.If condition body
     (SubscriptAccess, [ base, element ]) -> Just $ S.SubscriptAccess base element
     (For, lhs : expr : rest ) -> Just $ S.For [lhs, expr] rest

src/Parser.hs

@@ -78,5 +78,5 @@ markdownParser = AssignmentParser MarkdownParser Markdown.assignment
 
 -- | A fallback parser that treats a file simply as rows of strings.
 lineByLineParser :: Source -> SyntaxTerm DefaultFields
-lineByLineParser source = (totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source))
-  where toLine line range = (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source))
+lineByLineParser source = Term ((totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source)))
+  where toLine line range = Term ((range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source)))

src/RWS.hs

@@ -24,7 +24,7 @@ import Data.Record
 import Data.Semigroup hiding (First(..))
 import Data.These
 import Data.Traversable
-import Term hiding (term)
+import Term
 import Data.Array.Unboxed
 import Data.Functor.Classes
 import SES
@@ -139,7 +139,7 @@ findNearestNeighbourToDiff' :: (Diff f fields -> Int) -- ^ A function computes a
                                     (Maybe (MappedDiff f fields))
 findNearestNeighbourToDiff' editDistance canCompare kdTrees termThing = case termThing of
   None -> pure Nothing
-  Term term -> Just <$> findNearestNeighbourTo editDistance canCompare kdTrees term
+  RWS.Term term -> Just <$> findNearestNeighbourTo editDistance canCompare kdTrees term
   Index i -> modify' (\ (_, unA, unB) -> (i, unA, unB)) >> pure Nothing
 
 -- | Construct a diff for a term in B by matching it against the most similar eligible term in A (if any), marking both as ineligible for future matches.
@@ -212,7 +212,7 @@ genFeaturizedTermsAndDiffs :: (Functor f, HasField fields FeatureVector)
 genFeaturizedTermsAndDiffs sesDiffs = let Mapping _ _ a b c d = foldl' combine (Mapping 0 0 [] [] [] []) sesDiffs in (reverse a, reverse b, reverse c, reverse d)
   where combine (Mapping counterA counterB as bs mappedDiffs allDiffs) diff = case diff of
           This term -> Mapping (succ counterA) counterB (featurize counterA term : as) bs mappedDiffs (None : allDiffs)
-          That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (Term (featurize counterB term) : allDiffs)
+          That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (RWS.Term (featurize counterB term) : allDiffs)
           These a b -> Mapping (succ counterA) (succ counterB) as bs ((These counterA counterB, These a b) : mappedDiffs) (Index counterA : allDiffs)
 
 data Mapping f fields = Mapping {-# UNPACK #-} !Int {-# UNPACK #-} !Int ![UnmappedTerm f fields] ![UnmappedTerm f fields] ![MappedDiff f fields] ![TermOrIndexOrNone (UnmappedTerm f fields)]
@@ -221,7 +221,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 (record :< functor) = setFeatureVector record nullFeatureVector :< functor
+eraseFeatureVector (Term.Term (record :< functor)) = Term.Term (setFeatureVector record nullFeatureVector :< functor)
 
 nullFeatureVector :: FeatureVector
 nullFeatureVector = listArray (0, 0) [0]
@@ -255,7 +255,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) = ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor)
+ where collect ((gram :. rest) :< functor) = Term.Term ((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))
 
@@ -273,7 +273,7 @@ pqGramDecorator
 pqGramDecorator getLabel p q = cata algebra
   where
     algebra term = let label = getLabel term in
-      ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label)
+      Term.Term ((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))
 
@@ -281,10 +281,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 ((gram :. rest) :< functor) = do
+    assignLabels label (Term.Term ((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)
+      pure $! Term.Term ((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)

src/Renderer.hs

@@ -74,7 +74,7 @@ data SomeRenderer f where
 deriving instance Show (SomeRenderer f)
 
 identifierAlgebra :: RAlgebra (TermF Syntax a) (Term Syntax a) (Maybe Identifier)
-identifierAlgebra (_ :<< syntax) = case syntax of
+identifierAlgebra (_ :< syntax) = case syntax of
   S.Assignment f _ -> identifier f
   S.Class f _ _ -> identifier f
   S.Export f _ -> f >>= identifier

src/Renderer/JSON.hs

@@ -56,8 +56,8 @@ instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a
   toEncoding = pairs . mconcat . toJSONFields
 
 instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) where
-  toJSON (a :< f) = object (toJSONFields a <> toJSONFields f)
-  toEncoding (a :< f) = pairs (mconcat (toJSONFields a <> toJSONFields f))
+  toJSON = object . toJSONFields
+  toEncoding = pairs . mconcat . toJSONFields
 
 class ToJSONFields a where
   toJSONFields :: KeyValue kv => a -> [kv]
@@ -85,10 +85,10 @@ instance ToJSONFields a => ToJSONFields (Maybe a) where
   toJSONFields = maybe [] toJSONFields
 
 instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where
-  toJSONFields (a :< f) = toJSONFields a <> toJSONFields f
+  toJSONFields = toJSONFields . unTerm
 
 instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where
-  toJSONFields (a :<< f) = toJSONFields a <> toJSONFields f
+  toJSONFields (a :< f) = toJSONFields a <> toJSONFields f
 
 instance (ToJSONFields a, ToJSONFields (f (Diff f a)), ToJSONFields (f (Term f a))) => ToJSONFields (Diff f a) where
   toJSONFields = toJSONFields . unDiff

src/Renderer/SExpression.hs

@@ -43,7 +43,7 @@ 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 (annotation :< syntax) parentLevel level =
+    go (Term (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

src/Renderer/TOC.hs

@@ -98,12 +98,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 :<< _) = 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 :<< 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, _)) _ _
@@ -118,7 +118,7 @@ syntaxDeclarationAlgebra Blob{..} (a :<< 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 :<< 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
@@ -129,7 +129,7 @@ declarationAlgebra blob@Blob{..} (a :<< 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 :<< 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
@@ -154,7 +154,7 @@ tableOfContentsBy :: (Foldable f, Functor f)
                   -> [Entry a]                                   -- ^ A list of entries for relevant changed and unchanged nodes in the diff.
 tableOfContentsBy selector = fromMaybe [] . cata diffAlgebra
   where diffAlgebra r = case r of
-          Copy ann r -> case (selector (Both.snd ann :<< r), fold r) of
+          Copy ann r -> case (selector (Both.snd ann :< r), fold r) of
             (Just a, Nothing) -> Just [Unchanged a]
             (Just a, Just []) -> Just [Changed a]
             (_     , entries) -> entries

src/Semantic/Task.hs

@@ -220,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 :<< 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

src/Term.hs

@@ -5,8 +5,6 @@ module Term
 , SyntaxTerm
 , SyntaxTermF
 , termSize
-, term
-, unTerm
 , extract
 , unwrap
 , hoistTerm
@@ -25,12 +23,12 @@ import Data.Proxy
 import Data.Record
 import Data.Union
 import Syntax
+import Text.Show
 
 -- | A Term with an abstract syntax tree and an annotation.
+newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
 infixr 5 :<
-data Term syntax ann = ann :< syntax (Term syntax ann)
-infixr 5 :<<
-data TermF syntax ann recur = (:<<) { headF :: ann, tailF :: syntax recur }
+data TermF syntax ann recur = (:<) { headF :: ann, tailF :: syntax recur }
   deriving (Eq, Foldable, Functor, Show, Traversable)
 
 -- | A Term with a Syntax leaf and a record of fields.
@@ -40,17 +38,11 @@ type SyntaxTermF fields = TermF Syntax (Record fields)
 -- | Return the node count of a term.
 termSize :: (Foldable f, Functor f) => Term f annotation -> Int
 termSize = cata size where
-  size (_ :<< syntax) = 1 + sum syntax
+  size (_ :< syntax) = 1 + sum syntax
 
 
-term :: TermF f a (Term f a) -> Term f a
-term (a :<< f) = a :< f
-
-unTerm :: Term f a -> TermF f a (Term f a)
-unTerm (a :< f) = a :<< f
-
 hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a
-hoistTerm f = go where go (a :< r) = a :< f (fmap go r)
+hoistTerm f = go where go (Term (a :< r)) = Term (a :< f (fmap go r))
 
 -- | Strips the head annotation off a term annotated with non-empty records.
 stripTerm :: Functor f => Term f (Record (h ': t)) -> Term f (Record t)
@@ -62,7 +54,7 @@ liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl)
 
 
 instance Apply1 Pretty1 fs => Pretty1 (Term (Union fs)) where
-  liftPretty p pl = go where go (a :< f) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f
+  liftPretty p pl = go where go (Term (a :< f)) = p a <+> liftPrettyUnion go (Pretty.list . map (liftPretty p pl)) f
 
 instance (Apply1 Pretty1 fs, Pretty a) => Pretty (Term (Union fs) a) where
   pretty = liftPretty pretty prettyList
@@ -70,59 +62,59 @@ instance (Apply1 Pretty1 fs, Pretty a) => Pretty (Term (Union fs) a) where
 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 => Corecursive (Term f a) where embed = Term
 
 instance Functor f => Comonad (Term f) where
-  extract (a :< _) = a
-  duplicate w = w :< fmap duplicate (unwrap w)
-  extend f = go where go w = f w :< fmap go (unwrap w)
+  extract (Term (a :< _)) = a
+  duplicate w = Term (w :< fmap duplicate (unwrap w))
+  extend f = go where go w = Term (f w :< fmap go (unwrap w))
 
 instance Functor f => Functor (Term f) where
-  fmap f = go where go (a :< r) = f a :< fmap go r
+  fmap f = go where go (Term (a :< r)) = Term (f a :< fmap go r)
 
 instance Functor f => ComonadCofree f (Term f) where
-  unwrap (_ :< as) = as
+  unwrap (Term (_ :< as)) = as
   {-# INLINE unwrap #-}
 
 instance Eq1 f => Eq1 (Term f) where
-  liftEq eqA = go where go (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq go f1 f2
+  liftEq eqA = go where go (Term (a1 :< f1)) (Term (a2 :< f2)) = eqA a1 a2 && liftEq go f1 f2
 
 instance (Eq1 f, Eq a) => Eq (Term f a) where
   (==) = eq1
 
 instance Show1 f => Show1 (Term f) where
-  liftShowsPrec spA slA = go where go d (a :< f) = showParen (d > 5) $ spA 6 a . showString " :< " . liftShowsPrec go (liftShowList spA slA) 5 f
+  liftShowsPrec spA slA = go where go d = showsUnaryWith (liftShowsPrec2 spA slA go (showListWith (go 0))) "Term" d . unTerm
 
 instance (Show1 f, Show a) => Show (Term f a) where
   showsPrec = showsPrec1
 
 instance Functor f => Bifunctor (TermF f) where
-  bimap f g (a :<< r) = f a :<< fmap g r
+  bimap f g (a :< r) = f a :< fmap g r
 
 instance Listable1 f => Listable2 (TermF f) where
-  liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<<)
+  liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<)
 
 instance (Listable1 f, Listable a) => Listable1 (TermF f a) where
   liftTiers = liftTiers2 tiers
 
 instance (Functor f, Listable1 f) => Listable1 (Term f) where
   liftTiers annotationTiers = go
-    where go = liftCons1 (liftTiers2 annotationTiers go) term
+    where go = liftCons1 (liftTiers2 annotationTiers go) Term
 
 instance Eq1 f => Eq2 (TermF f) where
-  liftEq2 eqA eqB (a1 :<< f1) (a2 :<< f2) = eqA a1 a2 && liftEq eqB f1 f2
+  liftEq2 eqA eqB (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq eqB f1 f2
 
 instance (Eq1 f, Eq a) => Eq1 (TermF f a) where
   liftEq = liftEq2 (==)
 
 instance Show1 f => Show2 (TermF f) where
-  liftShowsPrec2 spA _ spB slB d (a :<< f) = showParen (d > 5) $ spA 6 a . showString " :<< " . liftShowsPrec spB slB 5 f
+  liftShowsPrec2 spA _ spB slB d (a :< f) = showParen (d > 5) $ spA 6 a . showString " :< " . liftShowsPrec spB slB 5 f
 
 instance (Show1 f, Show a) => Show1 (TermF f a) where
   liftShowsPrec = liftShowsPrec2 showsPrec showList
 
 instance Pretty1 f => Pretty2 (TermF f) where
-  liftPretty2 pA _ pB plB (a :<< f) = pA a <+> liftPretty pB plB f
+  liftPretty2 pA _ pB plB (a :< f) = pA a <+> liftPretty pB plB f
 
 instance (Pretty1 f, Pretty a) => Pretty1 (TermF f a) where
   liftPretty = liftPretty2 pretty prettyList

src/TreeSitter.hs

@@ -64,7 +64,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) :<< 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
@@ -109,7 +109,7 @@ nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos no
 assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields)
 assignTerm language source annotation children allChildren =
   case assignTermByLanguage source (category annotation) children of
-    Just a -> pure (annotation :< a)
+    Just a -> pure (Term (annotation :< a))
     _ -> defaultTermAssignment source annotation children allChildren
   where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields))
         assignTermByLanguage = case languageForTSLanguage language of
@@ -120,7 +120,7 @@ assignTerm language source annotation children allChildren =
 
 defaultTermAssignment :: Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields)
 defaultTermAssignment source annotation children allChildren
-  | category annotation `elem` operatorCategories = (annotation :<) . S.Operator <$> allChildren
+  | category annotation `elem` operatorCategories = Term . (annotation :<) . S.Operator <$> allChildren
   | otherwise = case (category annotation, children) of
     (ParseError, children) -> toTerm $ S.ParseError children
 
@@ -155,7 +155,7 @@ defaultTermAssignment source annotation children allChildren
                 [_, Other t]
                   | t `elem` ["--", "++"] -> MathOperator
                 _ -> Operator
-      pure ((setCategory annotation c) :< S.Operator cs)
+      pure (Term (setCategory annotation c :< S.Operator cs))
 
     (Other "binary_expression", _) -> do
       cs <- allChildren
@@ -166,7 +166,7 @@ defaultTermAssignment source annotation children allChildren
                   | s `elem` ["&&", "||"] -> BooleanOperator
                   | s `elem` [">>", ">>=", ">>>", ">>>=", "<<", "<<=", "&", "^", "|"] -> BitwiseOperator
                 _ -> Operator
-      pure ((setCategory annotation c) :< S.Operator cs)
+      pure (Term (setCategory annotation c :< S.Operator cs))
 
     (_, []) -> toTerm $ S.Leaf (toText source)
     (_, children) -> toTerm $ S.Indexed children
@@ -181,7 +181,7 @@ defaultTermAssignment source annotation children allChildren
           , RelationalOperator
           , BitwiseOperator
           ]
-        toTerm = pure . (annotation :<)
+        toTerm = pure . Term . (annotation :<)
 
 
 categoryForLanguageProductionName :: Ptr TS.Language -> Text -> Category