From b7e211c9c229566e19394057bedafb94367464ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Sep 2017 11:47:10 +0100 Subject: [PATCH] Redefine Term as a wrapper for TermF. --- src/Algorithm.hs | 2 +- src/Alignment.hs | 8 +++--- src/Data/Syntax.hs | 2 +- src/Data/Syntax/Algebra.hs | 6 ++--- src/Data/Syntax/Assignment.hs | 8 +++--- src/Decorators.hs | 4 +-- src/Diff.hs | 6 ++--- src/Interpreter.hs | 6 ++--- src/Language.hs | 14 +++++----- src/Language/Markdown.hs | 2 +- src/Language/Markdown/Syntax.hs | 9 +++---- src/Language/Ruby.hs | 8 +++--- src/Parser.hs | 4 +-- src/RWS.hs | 16 +++++------ src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 8 +++--- src/Renderer/SExpression.hs | 2 +- src/Renderer/TOC.hs | 10 +++---- src/Semantic/Task.hs | 2 +- src/Term.hs | 48 ++++++++++++++------------------- src/TreeSitter.hs | 12 ++++----- 21 files changed, 85 insertions(+), 94 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 4769cba79..18c9a3037 100644 --- a/src/Algorithm.hs +++ b/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. diff --git a/src/Alignment.hs b/src/Alignment.hs index 62433fd37..43f1afbeb 100644 --- a/src/Alignment.hs +++ b/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])] diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 4cb29b424..187efa6b6 100644 --- a/src/Data/Syntax.hs +++ b/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 diff --git a/src/Data/Syntax/Algebra.hs b/src/Data/Syntax/Algebra.hs index a0e87c725..73701d2ab 100644 --- a/src/Data/Syntax/Algebra.hs +++ b/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) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 7eb92d5a1..410b1e5ab 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/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. diff --git a/src/Decorators.hs b/src/Decorators.hs index 463dac736..7b646e893 100644 --- a/src/Decorators.hs +++ b/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 diff --git a/src/Diff.hs b/src/Diff.hs index ba7ddb7e5..236683932 100644 --- a/src/Diff.hs +++ b/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 diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0a9bf5790..5667f3246 100644 --- a/src/Interpreter.hs +++ b/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. diff --git a/src/Language.hs b/src/Language.hs index 9b3178eee..b2fee057a 100644 --- a/src/Language.hs +++ b/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)) diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index b33727117..055d50236 100644 --- a/src/Language/Markdown.hs +++ b/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))) diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 89899ad98..677748c74 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/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)) diff --git a/src/Language/Ruby.hs b/src/Language/Ruby.hs index dacbcfb24..1b4bde5f7 100644 --- a/src/Language/Ruby.hs +++ b/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 diff --git a/src/Parser.hs b/src/Parser.hs index f88c41048..78e081820 100644 --- a/src/Parser.hs +++ b/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))) diff --git a/src/RWS.hs b/src/RWS.hs index 8fd38ae5d..fdfadded4 100644 --- a/src/RWS.hs +++ b/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) diff --git a/src/Renderer.hs b/src/Renderer.hs index 11cb31d03..9b0bb09ae 100644 --- a/src/Renderer.hs +++ b/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 diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index e9606445f..88d50de76 100644 --- a/src/Renderer/JSON.hs +++ b/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 diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index 15e01a828..c34f5b816 100644 --- a/src/Renderer/SExpression.hs +++ b/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 diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 2443b8dd6..ac86a9262 100644 --- a/src/Renderer/TOC.hs +++ b/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 diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 899cb2465..a1b062106 100644 --- a/src/Semantic/Task.hs +++ b/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 diff --git a/src/Term.hs b/src/Term.hs index 0fc62533f..4d8db5473 100644 --- a/src/Term.hs +++ b/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 diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index c94d71780..253dfa8bc 100644 --- a/src/TreeSitter.hs +++ b/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