mirror of
https://github.com/github/semantic.git
synced 2024-12-29 01:42:43 +03:00
Redefine Term as a wrapper for TermF.
This commit is contained in:
parent
1267fe5ea7
commit
b7e211c9c2
@ -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.
|
||||
|
@ -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])]
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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))
|
||||
|
@ -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)))
|
||||
|
||||
|
@ -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))
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)))
|
||||
|
16
src/RWS.hs
16
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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
48
src/Term.hs
48
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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user