1
1
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:
Rob Rix 2017-09-09 11:47:10 +01:00
parent 1267fe5ea7
commit b7e211c9c2
21 changed files with 85 additions and 94 deletions

View File

@ -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.

View File

@ -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])]

View File

@ -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 terms annotation.
makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply1 Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a

View File

@ -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 scopes complexity.
-- TODO: Inner functions should not increase parent scopes 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)

View File

@ -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.

View File

@ -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

View File

@ -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

View File

@ -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.

View File

@ -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))

View File

@ -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)))

View File

@ -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))

View File

@ -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

View File

@ -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)))

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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