From 85c3754934c4ede49112a006490ededf0bc96d75 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 23 Nov 2017 13:27:21 -0500 Subject: [PATCH] :fire: the Comonad & ComonadCofree instances for Term. --- src/Data/Term.hs | 13 ------------- src/Decorator.hs | 4 ++-- src/Language.hs | 23 +++++++++++------------ src/Language/Go.hs | 40 +++++++++++++++++++--------------------- src/Parser/TreeSitter.hs | 8 ++++---- src/RWS.hs | 10 +++++----- src/Renderer/TOC.hs | 6 +++--- 7 files changed, 44 insertions(+), 60 deletions(-) diff --git a/src/Data/Term.hs b/src/Data/Term.hs index 69f41c76f..a0df449e2 100644 --- a/src/Data/Term.hs +++ b/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) diff --git a/src/Decorator.hs b/src/Decorator.hs index 5e233f2d2..5177ad26c 100644 --- a/src/Decorator.hs +++ b/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. diff --git a/src/Language.hs b/src/Language.hs index 01b3bfa91..a5bb79b24 100644 --- a/src/Language.hs +++ b/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 diff --git a/src/Language/Go.hs b/src/Language/Go.hs index e390e8f4c..1389c0d19 100644 --- a/src/Language/Go.hs +++ b/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 diff --git a/src/Parser/TreeSitter.hs b/src/Parser/TreeSitter.hs index c218d644f..1a498f781 100644 --- a/src/Parser/TreeSitter.hs +++ b/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 diff --git a/src/RWS.hs b/src/RWS.hs index 471f8b1d6..36fca6355 100644 --- a/src/RWS.hs +++ b/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 diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 13746a072..a9407f08e 100644 --- a/src/Renderer/TOC.hs +++ b/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)